EXCEL – 检查/识别多行和另一张纸上的重复文本
20世纪20年代初期，我在纽约有犯罪分子的名字和姓氏。我已经缩小了我正在关注的某些犯罪部门，但是我想把这些名字与更广泛的数据库进行交叉参考，看他们是否犯了其他罪行。 问题是，名字和姓氏在不同的单元格中。 所以，到目前为止我所能做到的最好的一点是，如果姓氏匹配，则标记为“X”，如果名字匹配，则在旁边的列中标记“X”。 这个问题是，虽然它缩小了它，但有很多人的名字是“亚当”，例如很多名字是“布朗”，所以它没有显示实际上是匹配的。
因此，电子表格1'S1'在C2中具有姓氏（例如布朗），在D2中具有名字（例如约翰），而电子表格2'S2'在C2和D2中具有完全不同的名称，所以我需要search所有列的C，然后D进行比赛。
有没有写这个代码的方法？ 有任何想法吗？！
如果自定义报告更方便，下面的VBA代码需要额外的表格
假设您的工作表是“工作表1”（S1），“工作表2”（S2）和工作表3（报表），则解决scheme将在工作表3上生成一个列表，其中包含来自S1的唯一的FirstName + LastName
- B列将显示S1中存在多less重复项
- C栏= First Name（S1）
- D列=姓（S1）
- 列E将显示S2中存在多less重复项
附加function：
如果你点击S3上的任何名字（第一个或最后一个），它将过滤S1和S2的名字，类似于：
S1
S2
报告（S3）
点击S3中的“First3”（或“Last3”），就会得到
S1
S2
代码：
打开VBA编辑器： Alt + F11
- 插入一个新的通用模块：在左上窗格的任何地方右键单击并select插入 – >模块
- 在新模块（可能称为Module1）右窗格中，粘贴以下代码：
模块1 （共4个程序）：
Option Explicit Public Sub FindMatches() Dim ws1 As Worksheet, ws2 As Worksheet, d1 As Object, d2 As Object Set ws1 = Sheet1 Set ws2 = Sheet2 Set d1 = ReadNames(ws1) Set d2 = ReadNames(ws2) If Not d1 Is Nothing And Not d2 Is Nothing Then MatchNames d1, d2 Sheet3.Activate End Sub Private Function ReadNames(ByRef ws As Worksheet) As Object If Not ws Is Nothing Then Dim d As Object, ur As Variant, i As Long Set d = CreateObject("Scripting.Dictionary") d.CompareMode = TextCompare ur = ws.UsedRange.Columns("C:D") 'Read all names For i = LBound(ur) To UBound(ur) If Not d.Exists(ur(i, 1) & " " & ur(i, 2)) Then 'this keeps count of dupes d(ur(i, 1) & " " & ur(i, 2)) = 1 Else d(ur(i, 1) & " " & ur(i, 2)) = d(ur(i, 1) & " " & ur(i, 2)) + 1 End If Next Set ReadNames = d End If End Function 'Generates list of unique names on Sheet3, for full names from Sheet1, found on Sheet2 Private Sub MatchNames(ByRef d1 As Object, d2 As Object) If Not d1 Is Nothing And Not d2 Is Nothing Then Dim ur As Variant, itm As Variant, i As Long, fl As Variant With Sheet3 'Or use Worksheets("Sheet3") 'or "Matches", or "Report", etc .UsedRange.EntireRow.Delete ur = .Range(.Cells(1, 2), .Cells(d1.Count, 5)) End With ur(1, 1) = "Sheet1 Count": ur(1, 4) = "Sheet2 Count" ur(1, 2) = "First Name": ur(1, 3) = "Last Name" i = 2 For Each itm In d1 If d2.Exists(itm) Then ur(i, 1) = d1(itm) fl = Split(itm) ur(i, 2) = fl(0) ur(i, 3) = fl(1) ur(i, 4) = d2(itm) i = i + 1 End If Next With Sheet3 .Range(.Cells(1, 2), .Cells(d1.Count, 5)) = ur With .UsedRange.Columns .EntireColumn.AutoFit .HorizontalAlignment = xlCenter End With End With End If End Sub
Public Sub FilterNames(ByRef ws As Worksheet, ByVal fName As String, lName As String) With ws.UsedRange .AutoFilter Field:=4, Criteria1:=lName .AutoFilter Field:=3, Criteria1:=fName End With End Sub
现在，在VBA编辑器中双击项目“Sheet3”（左上angular）打开它的模块并粘贴这个代码
“Sheet3”模块 （1程序）：
Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.CountLarge = 1 Then Dim lr As Long, fn As String, ln As String lr = Me.UsedRange.Rows.Count With Target If (.Row > 1 And .Row <= lr) And (.Column = 3 Or .Column = 4) Then fn = .Value2 ln = .Offset(, 1).Value2 If .Column = 4 Then fn = .Offset(, -1).Value2 ln = .Value2 End If FilterNames Sheet1, fn, ln FilterNames Sheet2, fn, ln Else If Sheet1.AutoFilterMode Then Sheet1.UsedRange.AutoFilter If Sheet2.AutoFilterMode Then Sheet2.UsedRange.AutoFilter End If End With Sheet1.Activate End If End Sub
执行代码
- 再次双击Module1
- 将鼠标光标放置在顶部Sub
FindMatches() - 按F5
确保所有工作表完全命名为“工作表1”，“工作表2”和“工作表3”
希望这可以帮助