VBA to check two columns for duplicate values (Active sheet to all sheets)

[theishv]

Hello!

This might be an easy question, but i hope you can help.

In an earlier thread i asked for some help regarding a code that will check two columns for duplicate values. Both the values in the same row of the columns has to match the values in a row somewhere else in the columns. When such a match is found the bottom most row should be deleted.

I got an excellent code, which works:

Code:
Sub DeleteDupes()

Dim Cl As Range
Dim ValU As String
Dim Rng As Range

With CreateObject("scripting.dictionary")
For Each Cl In Range("D1", Range("D" & Rows.Count).End(xlUp))
ValU = Cl.Value & Cl.Offset(, 1).Value
If Not .exists(ValU) Then
.Add ValU, Nothing
Else
If Rng Is Nothing Then
Set Rng = Cl
Else
Set Rng = Union(Rng, Cl)
End If
End If
Next Cl
End With
If Not Rng Is Nothing Then Rng.EntireRow.Delete

End Sub
However it only works on the active sheet.
What should be added to make it work on all sheets in the workbook. Additionally is it possible to make it display a textbox after all the lines are removed? The textbox should state the row numbers deleted in addition to the sheet names in which they are deleted and say that nothing is deleted if it can't find duplicates?

I appreciate you help

 

[Fluff]

Untested, but how about

Sub DeleteDupes()

   Dim Cl As Range
   Dim v1 As String, v2 As String
   Dim Rng As Range
   Dim ws As Worksheet
   Dim Msg As String
   Dim Dic As Object
   
   Set Dic = CreateObject("scripting.dictionary")
   For Each ws In Worksheets
      For Each Cl In ws.Range("D1", ws.Range("D" & Rows.Count).End(xlUp))
         If Len(trim(Cl.Value)) > 0 Then
            v1 = Cl.Value: v2 = Cl.Offset(, 1).Value
            If Not Dic.exists(v1) Then
               Dic.Add v1, CreateObject("scripting.dictionary")
               Dic(v1).Add v2, Nothing
            ElseIf Not Dic(v1).exists(v2) Then
               Dic(v1).Add v2, Nothing
            Else
               If Rng Is Nothing Then
                  Set Rng = Cl
                  Msg = Msg & vbLf & ws.Name & vbLf & Cl.Row
               Else
                  Set Rng = Union(Rng, Cl)
                  Msg = Msg & "," & Cl.Row
               End If
            End If
         End If
      Next Cl
      Dic.removeall
      If Not Rng Is Nothing Then Rng.EntireRow.Delete
      Set Rng = Nothing
   Next ws
   MsgBox Msg
End Sub

 

[theishv]

Untested, but how about

Sub DeleteDupes()

   Dim Cl As Range
   Dim v1 As String, v2 As String
   Dim Rng As Range
   Dim ws As Worksheet
   Dim Msg As String
   Dim Dic As Object
   
   Set Dic = CreateObject("scripting.dictionary")
   For Each ws In Worksheets
      For Each Cl In ws.Range("D1", ws.Range("D" & Rows.Count).End(xlUp))
         If Len(trim(Cl.Value)) > 0 Then
            v1 = Cl.Value: v2 = Cl.Offset(, 1).Value
            If Not Dic.exists(v1) Then
               Dic.Add v1, CreateObject("scripting.dictionary")
               Dic(v1).Add v2, Nothing
            ElseIf Not Dic(v1).exists(v2) Then
               Dic(v1).Add v2, Nothing
            Else
               If Rng Is Nothing Then
                  Set Rng = Cl
                  Msg = Msg & vbLf & ws.Name & vbLf & Cl.Row
               Else
                  Set Rng = Union(Rng, Cl)
                  Msg = Msg & "," & Cl.Row
               End If
            End If
         End If
      Next Cl
      Dic.removeall
      If Not Rng Is Nothing Then Rng.EntireRow.Delete
      Set Rng = Nothing
   Next ws
   MsgBox Msg
End Sub

Works exactly like it should. Thank you for all the help with this program, you are amazing!

 

[Fluff]

Glad to help & thanks for the feedback