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

 

[Roderick_E]

Do you need to loop through all sheets?

Sub WorksheetLoop2()


         ' Declare Current as a worksheet object variable.
         Dim Current As Worksheet


         ' Loop through all of the worksheets in the active workbook.
         For Each Current In Worksheets


            ' Insert your code here.
            
         Next


      End Sub

 

[Fluff]

Try this

Sub DeleteDupes()

   Dim Cl As Range
   Dim ValU As String
   Dim Rng As Range
   Dim Ws As Worksheet
   Dim Msg As String
   
   With CreateObject("scripting.dictionary")
      For Each Ws In Worksheets
         For Each Cl In Ws.Range("D1", Ws.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
                  Msg = Msg & vbLf & Ws.Name & vbLf & Cl.Row
               Else
                  Set Rng = Union(Rng, Cl)
                  Msg = Msg & "," & Cl.Row
               End If
            End If
         Next Cl
         If Not Rng Is Nothing Then Rng.EntireRow.Delete
         Set Rng = Nothing
      Next Ws
   End With
   MsgBox Msg
End Sub

Depending on how many rows are being deleted, the msgbox may not show everything, as there is a limit to the amount of info it can show.

 

[theishv]

Try this

Sub DeleteDupes()[/INDENT]

   Dim Cl As Range
   Dim ValU As String
   Dim Rng As Range
   Dim Ws As Worksheet
   Dim Msg As String
   
   With CreateObject("scripting.dictionary")
      For Each Ws In Worksheets
         For Each Cl In Ws.Range("D1", Ws.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
                  Msg = Msg & vbLf & Ws.Name & vbLf & Cl.Row
               Else
                  Set Rng = Union(Rng, Cl)
                  Msg = Msg & "," & Cl.Row
               End If
            End If
         Next Cl
         If Not Rng Is Nothing Then Rng.EntireRow.Delete
         Set Rng = Nothing
      Next Ws
   End With
   MsgBox Msg
End Sub

Depending on how many rows are being deleted, the msgbox may not show everything, as there is a limit to the amount of info it can show.

Works amazingly thank you!!

Just two things:

I think i formulated my self a bit unclear. Is it possible to make it loop through each sheet individually, so two similar rows in different sheets does not make one of them dissapear?

Sheets in which both column D and E are empty, row number 1 is deleted, is it possible to stop it from doing that (as in only deleting rows in which D and E has values)?​

 

[Fluff]

How about

Sub DeleteDupes()

   Dim Cl As Range
   Dim ValU As String
   Dim Rng As Range
   Dim Ws As Worksheet
   Dim Msg As String
   
   With CreateObject("scripting.dictionary")
      For Each Ws In Worksheets
         For Each Cl In Ws.Range("D1", Ws.Range("D" & Rows.Count).End(xlUp))
            ValU = Cl.Value & Cl.Offset(, 1).Value
            If Len(ValU) > 0 Then
               If Not .exists(ValU) Then
                  .Add ValU, 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
         .removeall
         If Not Rng Is Nothing Then Rng.EntireRow.Delete
         Set Rng = Nothing
      Next Ws
   End With
   MsgBox Msg
End Sub

 

[theishv]

How about

Sub DeleteDupes()

   Dim Cl As Range
   Dim ValU As String
   Dim Rng As Range
   Dim Ws As Worksheet
   Dim Msg As String
   
   With CreateObject("scripting.dictionary")
      For Each Ws In Worksheets
         For Each Cl In Ws.Range("D1", Ws.Range("D" & Rows.Count).End(xlUp))
            ValU = Cl.Value & Cl.Offset(, 1).Value
            If Len(ValU) > 0 Then
               If Not .exists(ValU) Then
                  .Add ValU, 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
         .removeall
         If Not Rng Is Nothing Then Rng.EntireRow.Delete
         Set Rng = Nothing
      Next Ws
   End With
   MsgBox Msg
End Sub

You are an excel wizard, it works like a charm!

The only thing is it sometimes deletes rows containing only spaces(it should not). Is it possible to make it apply only to rows in which column "D" contains numbers or something similar to avoid this problem?

Your help is very much appreciated!

 

[Fluff]

Try

Sub DeleteDupes()

   Dim Cl As Range
   Dim ValU As String
   Dim Rng As Range
   Dim ws As Worksheet
   Dim Msg As String
   
   With 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
               ValU = Cl.Value & Cl.Offset(, 1).Value
               If Not .exists(ValU) Then
                  .Add ValU, 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
         .removeall
         If Not Rng Is Nothing Then Rng.EntireRow.Delete
         Set Rng = Nothing
      Next ws
   End With
   MsgBox Msg
End Sub

 

[theishv]

Try

Sub DeleteDupes()

   Dim Cl As Range
   Dim ValU As String
   Dim Rng As Range
   Dim ws As Worksheet
   Dim Msg As String
   
   With 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
               ValU = Cl.Value & Cl.Offset(, 1).Value
               If Not .exists(ValU) Then
                  .Add ValU, 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
         .removeall
         If Not Rng Is Nothing Then Rng.EntireRow.Delete
         Set Rng = Nothing
      Next ws
   End With
   MsgBox Msg
End Sub

Thank you once again!

 

[Fluff]

You're welcome

 

[theishv]

Try

Sub DeleteDupes()

   Dim Cl As Range
   Dim ValU As String
   Dim Rng As Range
   Dim ws As Worksheet
   Dim Msg As String
   
   With 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
               ValU = Cl.Value & Cl.Offset(, 1).Value
               If Not .exists(ValU) Then
                  .Add ValU, 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
         .removeall
         If Not Rng Is Nothing Then Rng.EntireRow.Delete
         Set Rng = Nothing
      Next ws
   End With
   MsgBox Msg
End Sub

hi, i have another question

I use this program through a lot of data and occasionally run into this problem.

If one row contains 14652 in column D and 14 in column E while another row contains 146521 in column D and 4 in column E, the bottom most row will get deleted.

I believe this is due to the fact that both added together is 1465214, is there a way to solve this problem?

Theis