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

T

theishv

New Member
Joined
Jan 18, 2018
Messages
12
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




 

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
Sort by date Sort by votes
Do you need to loop through all sheets?

Code: 
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
 
Upvote 0
Try this
Code: 
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.
 
Upvote 0
Fluff said:
Try this
Code: 
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.
Click to expand...

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)?​
 
Upvote 0
How about
Code: 
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
 
Upvote 0
Fluff said:
How about
Code: 
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
Click to expand...

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!
 
Upvote 0
Try
Code: 
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
 
Upvote 0
Fluff said:
Try
Code: 
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
Click to expand...

Thank you once again!
 
Upvote 0
Fluff said:
Try
Code: 
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
Click to expand...

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
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

JohnPoole
  • Solved
Delete rows based on unique values
2
Replies
17
Views
865
kevin9999
K
S
  • Question
Copy/paste special values of Excel table based on cell value
Replies
2
Views
148
stacey_t
S
B
  • Question
Delete "Invisible" Rows
Replies
5
Views
435
MARK858
MARK858
J
  • Solved
VBA to merge duplicate rows and sum values in certain column with adjustments
Replies
9
Views
314
Alex Blakenburg
A
J
  • Solved
VBA to compare rows in two different sheets, if match highlight cell
2
Replies
10
Views
562
kevin9999
K

Forum statistics

Threads
1,214,400
Messages
6,119,288
Members
448,885
Latest member
LokiSonic

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top