CODEWITHSUNDEEP
excelvbaduplicates
fantazm
fantazm

Reputation: 3

Search for Duplicates across workbook and report cell address

I am basically try to create a VBA that finds duplicates across the whole workbook, highlights them red, and lists the cell address of the duplicate(s) in an adjacent cell. Not sure if this is possible. I can make it highlight duplicates in red in a single sheet, but not across a workbook. And no idea how to get it to report the cell.address. Basically what the FIND function does, when I Ctrl+F and "Find All" it lists all the duplicates and the cell address of the duplicates. But I need it to be able to check multiple worksheets of hundreds of lines of data, instead of me searching one at a time.

For Example (sorry can't embed a picture atm)

SHEET 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

SHEET2:

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

Is something like this possible?

EDIT I was using this initially to highlight in red - but I have more sheets now and this is going to get long. I know I need something like.. "For Each ws In ThisWorkbook.Worksheets" but not sure where and how to change what I have to use it.. I feel like I'd need something totally different and wouldn't be able to use my existing code. And then adding in the cell.address to an adjacent cell alludes me completeley.

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

EDIT

enter image description here

Upvotes: 0

Views: 160

Answers (1)

braX
braX

Reputation: 11755

First, build a dictionary of all the values in column B of all the sheets and then go back thru the sheets and highlight the duplicates...

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

There may be an easier way, but this should do what you want if I understand you correctly.

It looks like you are then also trying to create a summary which I did not include code for, but you can modify the Debug.Print part to build up a summary to add to a new sheet if that's what you are trying to do.

That should at least get you started in the right direction.

Update

Here is how to process the results using another dictionary. It still doesnt do EXACTLY what you want, but I cant be expected to write it ALL for you, right? You can use this example to get what you want:

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

3rd Update

OK, I was bored, so I added the last step, and combined step 1 and step 2 into one step. I came up with this, which isn't as easy to read, but it's less code, faster, and gives you all of what you wanted. Simple with dictionaries, eh?

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

Upvotes: 1

Related Questions