时间戳

首页 > 解决方案 > 有没有一种方法可以在 VBA 中编写代码来自动在列中写入重复值的文本？

excel - 有没有一种方法可以在 VBA 中编写代码来自动在列中写入重复值的文本？

问题描述

这是我在这里的第一个问题，因此对于任何错误或疏忽提前道歉。

我正在使用包含约 30,000 行人员详细信息的电子表格。每个人都有重复的条目（相同的姓氏、出生日期等），但名字经常不同。例如，约翰史密斯、J 史密斯、JM 史密斯。

电子表格提取

我希望编写代码来迭代地查看姓氏和出生日期以找到匹配的组。然后，由于最长的名字始终是正确的条目，因此该组中最大的名字长度将是我想要声明为正确的名字。

例如，在我附加的图片中：

单元格 C2、C3 和 C4 都有姓氏“Solo”。如果代码指向下一个单元格（C5），它将是“Stark”，因此它将停止计数。

然后它将通过检查所有相应的 DOB 匹配 (D2:D4) 来确认所有这些“Solo”是同一个人。之后，它将计算哪个单元格（B2、B3 或 B4）的长度最大。在这种情况下，B2 的长度最长。

最后，它将在整个组的“评论”单元格中写入所有这些匹配行 2，其对应的“ID”为“1”-“更正到 ID 1”。

谢谢您的帮助。我希望这有点清楚！

标签： excelvba

解决方案

使用以 Surname & DOB 作为键，以最长名字的行号作为值的Dictionary 对象。

Option Explicit

Sub ProcessNames()

    Dim wb As Workbook, ws As Worksheet
    Dim dict As Object, sKey As String
    Dim iLastRow As Long, iRow As Long

    Set dict = CreateObject("Scripting.Dictionary")

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Names") ' change to suit
    iLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row

    For iRow = 2 To iLastRow
        ' create key using LastName and DOB
        sKey = UCase(ws.Cells(iRow, "C")) & Format(Cells(iRow, "D"), "YYYYMMDD")

        If dict.exists(sKey) Then
            ' compare length of first names, store longest
            If Len(ws.Cells(iRow, "B")) > Len(ws.Cells(dict(sKey), "B")) Then
               dict(sKey) = iRow
            End If
        Else
            dict(sKey) = iRow
        End If

    Next

    ' update correct IDs in Comment
    For iRow = 2 To iLastRow
        sKey = UCase(ws.Cells(iRow, "C")) & Format(Cells(iRow, "D"), "YYYYMMDD")
        ws.Cells(iRow, "E") = "Correct to ID " & ws.Cells(dict(sKey), "A")
    Next

    MsgBox dict.Count & " names found in rows 2 to " & iLastRow, vbInformation

End Sub

推荐阅读