在工作簿中搜索重复项并报告单元格地址

Question

我基本上是在尝试创建一个 VBA，它可以在整个工作簿中查找重复项，将它们突出显示为红色，并列出相邻单元格中重复项的单元格地址。不确定这是否可能。我可以让它在单个工作表中以红色突出显示重复项，但不能在工作簿中突出显示。而且不知道如何让它报告cell.address。基本上 FIND 函数的作用是，当我 Ctrl+F 和“查找全部”时，它会列出所有重复项和重复项的单元格地址。但我需要它能够检查数百行数据的多个工作表，而不是一次搜索一个。

例如（抱歉无法在自动柜员机中嵌入图片）

表 1：

A -- B
1 Animal -- Duplicate
2 cat -- SHEET1 A5, SHEET2 A5
3 turtle
4 raccoon -- SHEET2 A4
5 cat -- SHEET1 A2, SHEET2 A5
6 monkey -- SHEET2 A7
7 whale

表 2：

A -- B
1 Animal -- Duplicate
2 dog
3 rat
4 raccoon -- SHEET1 A4
5 cat -- SHEET1 A2, SHEET1 A5
6 lizard
7 monkey -- SHEET1 A6

这样的事情可能吗？

编辑 我最初使用它来突出显示红色 - 但我现在有更多的床单，这会变得很长。 我知道我需要类似..“对于 ThisWorkbook.Worksheets 中的每个 ws”，但不确定在哪里以及如何更改我必须使用它的内容.. 我觉得我需要一些完全不同的东西并且无法使用我现有的代码。然后将 cell.address 添加到相邻的单元格中完全暗示了我。

Sub Duplicate_Digits()

Dim s1 As Worksheet: Set S1 = ThisWorkbook.Sheets("Sheet1")
Dim s2 As Worksheet: Set S2 = ThisWorkbook.Sheets("Sheet2")
Dim s3 As Worksheet: Set S3 = ThisWorkbook.Sheets("Sheet3")
Dim Numbers1, Numbers2, Numbers3, i
Dim Found As Range
Dim ws As Worksheet

Numbers1 = s1.Range("A2:A" & s1.Range("A" & 
s1.Rows.Count).End(xlUp).Row).Value
Numbers2 = s2.Range("A2:A" & s2.Range("A" & 
s2.Rows.Count).End(xlUp).Row).Value
Numbers3 = s3.Range("A2:A" & s3.Range("A" & 
s3.Rows.Count).End(xlUp).Row).Value

For i = LBound(Numbers2, 1) To UBound(Numbers2, 1)
    Set Found = s1.Range("A:A").Find(Numbers2(i, 1))
        If Not Found Is Nothing Then
            Found.Interior.Color = vbRed
        End If
    Set Found = Nothing
Next i

For i = LBound(Numbers3, 1) To UBound(Numbers3, 1)
    Set Found = s1.Range("A:A").Find(Numbers3(i, 1))
        If Not Found Is Nothing Then
            Found.Interior.Color = vbRed
        End If
    Set Found = Nothing
Next i

For i = LBound(Numbers1, 1) To UBound(Numbers1, 1)
    Set Found = s2.Range("A:A").Find(Numbers1(i, 1))
        If Not Found Is Nothing Then
            Found.Interior.Color = vbRed
        End If
    Set Found = Nothing
Next i

For i = LBound(Numbers3, 1) To UBound(Numbers3, 1)
    Set Found = s2.Range("A:A").Find(Numbers3(i, 1))
        If Not Found Is Nothing Then
            Found.Interior.Color = vbRed
        End If
    Set Found = Nothing
Next i

For i = LBound(Numbers1, 1) To UBound(Numbers1, 1)
    Set Found = s3.Range("A:A").Find(Numbers1(i, 1))
        If Not Found Is Nothing Then
            Found.Interior.Color = vbRed
        End If
    Set Found = Nothing
Next i

For i = LBound(Numbers2, 1) To UBound(Numbers2, 1)
    Set Found = s3.Range("A:A").Find(Numbers2(i, 1))
        If Not Found Is Nothing Then
            Found.Interior.Color = vbRed
        End If
    Set Found = Nothing
Next i

End Sub

编辑

Answer 1

首先，为所有工作表的 B 列中的所有值构建一个字典，然后返回工作表并突出显示重复项...

Sub FindDups()
  Dim sh As Worksheet
  Dim lRow As Long
  Dim lLastRow As Long
  Dim sText As String

  Dim dict As Object
  Set dict = CreateObject("Scripting.Dictionary")

  ' count unique values over all worksheets
  For Each sh In ActiveWorkbook.Worksheets
    lLastRow = sh.Range("B" & sh.Rows.Count).End(xlUp).Row
    For lRow = 1 To lLastRow
      sText = "" & sh.Range("B" & lRow).Value2
      If dict.Exists(sText) Then
        dict.Item(sText) = dict.Item(sText) + 1
      Else
        dict.Add sText, 1
      End If
    Next
  Next

  ' go back thru all the sheets and highlight the cells that have a count greater than 1
  For Each sh In ActiveWorkbook.Worksheets
    lLastRow = sh.Range("B" & sh.Rows.Count).End(xlUp).Row
    For lRow = 1 To lLastRow
      If dict.Item("" & sh.Range("B" & lRow).Value2) > 1 Then

        sh.Range("B" & lRow).Interior.Color = vbRed

        Debug.Print sh.Range("B" & lRow).Value2 & " - " & sh.Name & "!" & Replace(sh.Range("B" & lRow).Address, "$", "") & " - Count:" & dict.Item("" & sh.Range("B" & lRow).Value2)

        ' add the results to column C (?)
        sh.Range("C" & lRow).Value2 = sh.Range("B" & lRow).Value2 & " - " & sh.Name & "!" & Replace(sh.Range("B" & lRow).Address, "$", "") & " - Count:" & dict.Item("" & sh.Range("B" & lRow).Value2)

      Else
        ' add column C info for unique values found
        sh.Range("C" & lRow).Value2 = "Unique"
      End If
    Next
  Next

End Sub

可能有一种更简单的方法，但如果我理解正确的话，这应该可以满足你的要求。

您似乎也在尝试创建一个我没有包含代码的摘要，但您可以修改 Debug.Print 部分以构建一个摘要以添加到新工作表中，如果您正在尝试这样做做。

这至少应该让你朝着正确的方向开始。

更新

这里是如何使用另一个字典来处理结果。它仍然不能完全按照你的意愿做，但我不能指望我为你写这一切，对吧？你可以使用这个例子来得到你想要的：

Sub FindDups()
  Dim sh As Worksheet
  Dim lRow As Long
  Dim lLastRow As Long
  Dim sText As String

  Dim dict As Object
  Set dict = CreateObject("Scripting.Dictionary")

  ' count unique values over all worksheets
  For Each sh In ActiveWorkbook.Worksheets
    lLastRow = sh.Range("B" & sh.Rows.Count).End(xlUp).Row
    For lRow = 1 To lLastRow
      sText = "" & sh.Range("B" & lRow).Value2
      If dict.Exists(sText) Then
        dict.Item(sText) = dict.Item(sText) + 1
      Else
        dict.Add sText, 1
      End If
    Next
  Next

  Dim sKey As Variant
  Dim sReport As String
  Dim dict2 As Object
  Set dict2 = CreateObject("Scripting.Dictionary")

  ' go back thru all the sheets and highlight the cells that have a count greater than 1
  For Each sh In ActiveWorkbook.Worksheets
    lLastRow = sh.Range("B" & sh.Rows.Count).End(xlUp).Row
    For lRow = 1 To lLastRow
      sKey = "" & sh.Range("B" & lRow).Value2
      If dict.Item(sKey) > 1 Then

        sh.Range("B" & lRow).Interior.Color = vbRed

        'Debug.Print sKey & " - " & sh.Name & "!" & Replace(sh.Range("B" & lRow).Address, "$", "") & " - Count:" & dict.Item("" & sh.Range("B" & lRow).Value2)

        ' add the results to column C (?)
        'sh.Range("C" & lRow).Value2 = sReport

        ' add the values to a new dictionary object
        sReport = sh.Name & "!" & Replace(sh.Range("B" & lRow).Address, "$", "")
        If Not dict2.Exists(sKey) Then
          dict2.Add sKey, sReport & ", "
        Else
          dict2(sKey) = dict2(sKey) & sReport & ", "
        End If

      Else
        ' add column C info for unique values found
        sh.Range("C" & lRow).Value2 = "Unique"
      End If
    Next
  Next

  ' send the report to the debug window
  ' you can process this info however you want
  For Each sKey In dict2.Keys
    sReport = sKey & " - " & dict2.Item(sKey)
    Debug.Print Left$(sReport, Len(sReport) - 2)
  Next

End Sub

第三次更新

好的，我很无聊，所以我添加了最后一步，并将步骤 1 和步骤 2 合并为一个步骤。我想出了这个，它不是那么容易阅读，但它的代码更少，速度更快，并且给你所有你想要的。用字典很简单吧？

Sub FindDups()
  Dim sh As Worksheet
  Dim lRow As Long
  Dim lLastRow As Long
  Dim sKey As String
  Dim sReport As String

  Dim dictCount As Object
  Set dictCount = CreateObject("Scripting.Dictionary")
  Dim dictReport As Object
  Set dictReport = CreateObject("Scripting.Dictionary")

  For Each sh In ActiveWorkbook.Worksheets
    lLastRow = sh.Range("B" & sh.Rows.Count).End(xlUp).Row
    For lRow = 1 To lLastRow
      sKey = "" & sh.Range("B" & lRow).Value2
      sReport = sh.Name & "!" & Replace(sh.Range("B" & lRow).Address, "$", "")
      If Not dictCount.Exists(sKey) Then
        dictCount.Add sKey, 1
        dictReport.Add sKey, sReport & ", "
      Else
        dictCount.Item(sKey) = dictCount.Item(sKey) + 1
        dictReport(sKey) = dictReport(sKey) & sReport & ", "
      End If
    Next
  Next

  Dim sNewText As String
  For Each sh In ActiveWorkbook.Worksheets
    lLastRow = sh.Range("B" & sh.Rows.Count).End(xlUp).Row
    For lRow = 1 To lLastRow
      sKey = "" & sh.Range("B" & lRow).Value2
      If dictCount.Item(sKey) > 1 Then
        sh.Range("B" & lRow).Interior.Color = vbRed
        sNewText = Replace(dictReport(sKey), sh.Name & "!" & Replace(sh.Range("B" & lRow).Address, "$", "") & ", ", "")
        sh.Range("C" & lRow).Value = Left$(sNewText, Len(sNewText) - 2)
      Else
        sh.Range("C" & lRow).Value2 = "Unique"
      End If
    Next
  Next

End Sub