在VBA中是否有一种方法可以自动在列中为重复值写入文本？ [关闭]

Posted 2023-01-06

关闭。这个问题需要更多focused。它当前不接受答案。

---

是否要改善此问题？更新问题，使其仅按editing this post专注于一个问题。

[<14天前关闭。

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

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

Spreadsheet Extract

我希望编写代码，以遍历姓氏和DOB的方式查找匹配的组。然后，由于最长的名字始终是正确的条目，因此组中最大的名字长度就是我要声明为正确的名字。

例如，在我的附件图像中：

单元C2，C3和C4都具有姓氏'Solo'。如果代码进入下一个单元格（C5），它将是“ Stark”，因此它将在那里停止计数。

然后，通过检查所有各自的DOB匹配（D2：D4），将确认所有这些'Solo'是同一个人。之后，它将计算哪个单元格（B2，B3或B4）具有最大长度。在这种情况下，B2具有最长的长度。

最后，它将在整个组的'注释'单元中写入所有这些与第2行匹配的行，第2行具有相应的'ID'为'1'-'更正为ID 1'。

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

答案

使用以姓氏和DOB为键并以最长的名字的行号为值的Dictionary Object。

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