[RESOLVED] highlight duplicate rows include original instance.

I want all the duplicate rows highlighted in a worksheet along with original instance e.g. if I have row 1 with some data in multiple columns and the same date appears on row 20 then the macro should highlight both the row items in some same color. I got the below code through google search but when it try to run it gets stuck on the below line and shows error Run time Error '13' type mismatch. Excel version used by me is excel 2010. can someone help.

Code:

---

NewStr1 = NewStr1 & "||" & ws1.Cells(Row1.Row, Col1.Column) ' it's throwing runtime error on this line.

---

Code:

---

Option Explicit
Sub HighDupes()
Dim ws1 As Worksheet
Dim Row1 As Range
Dim Col1 As Range
Dim NewStr1 As String
'Needs reference to Microsoft Scripting Runtime
Dim MyDic As Dictionary
Set MyDic = New Dictionary
Set ws1 = ActiveWorkbook.Sheets(1)
Application.ScreenUpdating = False
For Each Row1 In ws1.UsedRange.Rows
'If rows are blank then skip
If Application.CountA(ws1.Rows(Row1.Row)) > 0 Then
NewStr1 = "Sheet1"
For Each Col1 In ws1.UsedRange.Columns
NewStr1 = NewStr1 & "||" & ws1.Cells(Row1.Row, Col1.Column) ' it's throwing runtime error on this line.
Next
If MyDic.exists(NewStr1) Then
'Colour intra sheet duplicates in sheet 1 as blue
ws1.Rows(Row1.Row).Interior.Color = vbBlue
ws1.Rows(MyDic(NewStr1)).Interior.Color = vbRed
Else
MyDic.Add NewStr1, Row1.Row
End If
End If
Next
Application.ScreenUpdating = True
Set MyDic = Nothing
Set ws1 = Nothing
End Sub

---

does the error occur on all columns? or just some?
you could try to explicitly convert the cell value to string, or use the cell text specifically

Code:

---

NewStr1 = NewStr1 & "||" & cstr(ws1.Cells(Row1.Row, Col1.Column))
'    OR
NewStr1 = NewStr1 & "||" & ws1.Cells(Row1.Row, Col1.Column).text

---

Great. It works now. I just need 1 more addition .i.e. to copy red or blue (either one) highlighted cells data including header (don't want to hard code the range, highlighted in bold) in a new sheet and name it as "Filtered out data" and delete all red and blue colored rows from the original worksheet.

Code:

---

Sheets.Add
    ActiveSheet.Name = "Filtered Out Data"
  ActiveSheet.Range("$A$1:$BG$3040").AutoFilter Field:=1, Criteria1:=RGB(0, 0 _
        , 255), Operator:=xlFilterCellColor
     
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Sheets("Filtered Out Data").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("A1").Select

---

as you do not store the rows that match, only change the colour, you would have to loop all the rows again

i would look at storing all the matched rows, to be able to work with them later

Ok. got it. in that case how do i filter for both blue and red rows at one go from base data and also I don't want to hard code the filter range (highlighted in bold). can you help

Code:

---

Option Explicit
Sub HighDupes()
Dim ws1 As Worksheet
Dim Row1 As Range
Dim Col1 As Range
Dim NewStr1 As String
'Needs reference to Microsoft Scripting Runtime
Dim MyDic As Dictionary
Set MyDic = New Dictionary
Set ws1 = ActiveWorkbook.Sheets(1)
Application.ScreenUpdating = False
For Each Row1 In ws1.UsedRange.Rows
'If rows are blank then skip
If Application.CountA(ws1.Rows(Row1.Row)) > 0 Then
NewStr1 = "Sheet1"
For Each Col1 In ws1.UsedRange.Columns
NewStr1 = NewStr1 & "||" & cstr(ws1.Cells(Row1.Row, Col1.Column))
Next
If MyDic.exists(NewStr1) Then
'Colour intra sheet duplicates in sheet 1 as blue
ws1.Rows(Row1.Row).Interior.Color = vbBlue
ws1.Rows(MyDic(NewStr1)).Interior.Color = vbRed
Else
MyDic.Add NewStr1, Row1.Row
End If
End If
Next
Application.ScreenUpdating = True
Set MyDic = Nothing
Set ws1 = Nothing

Sheets.Add
    ActiveSheet.Name = "Filtered Out Data"
Sheets(1).Select
  ActiveSheet.Range("$A$1:$BG$3040").AutoFilter Field:=1, Criteria1:=RGB(0, 0 _
        , 255), Operator:=xlFilterCellColor
     
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Sheets("Filtered Out Data").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Sheets(1).Select
  Cells.Select
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("A1").Select
End Sub

---

your original macro could have multiple matched rows, that did not all match each other
should they all get to copied (moved) to the same worksheet, or should the different matched rows each be moved to different worksheets?

do you actually need to colour the rows, or just move them?

Ok. Color coding is not important, I thought it makes it easy to identify the data using colors. I just need same original set of rows and same duplicate set of rows to be identified first and then move original set of rows to "filtered out data" worksheet and delete the both original set of rows and duplicated set of rows from Sheets (1). Color coding is just to identify the data which needs to be deleted from sheets(1) using the duplicates criteria.

can someone help with the above code.

Can you zip and attach a "before and after" example? I'm still a little unclear what you want exactly.

Quote:

---

Originally Posted by vbfbryce

Can you zip and attach a "before and after" example? I'm still a little unclear what you want exactly.

---

There were no attachments in this thread. I have a data in which I have some duplicate rows items (spanning across multiple colums) and I want to identify those duplicate row items along with original set of rows and move the original set of rows to a new worksheet and delete both original and duplicate set of rows. the initial code posted was to identify the duplicate and original set of rows through some color coding .i.e. blue and red.

Quote:

---

There were no attachments in this thread

---

we know that, bryce was asking you to attach one, so much easier to work with than trying to create a similar data set

you can test with this modification to your code, see if it does what you want

Code:

---

Dim ws1 As Worksheet
Dim Row1 As Range
Dim Col1 As Range
Dim NewStr1 As String
'Needs reference to Microsoft Scripting Runtime
Dim MyDic As Dictionary
Set MyDic = New Dictionary
Set ws1 = ActiveWorkbook.Sheets("sheet2")
Application.ScreenUpdating = False
For Each Row1 In ws1.UsedRange.Rows
    'If rows are blank then skip
    If Application.CountA(ws1.Rows(Row1.row)) > 0 Then
        NewStr1 = "ws1.name"
        For Each Col1 In ws1.UsedRange.Columns
        NewStr1 = NewStr1 & "||" & ws1.Cells(Row1.row, Col1.Column) ' it's throwing runtime error on this line.
        Next
        If MyDic.exists(NewStr1) Then
            Set rng = MyDic.Item(NewStr1)
           
            Set rng = Union(rng, Cells(Row1.row, 1).Resize(, ws1.UsedRange.Columns.Count))
            Set MyDic.Item(NewStr1) = rng
            'Colour intra sheet duplicates in sheet 1 as blue
            ''ws1.Rows(Row1.row).Interior.Color = vbBlue
            ''ws1.Rows(MyDic(NewStr1)).Interior.Color = vbRed
            Else
            MyDic.Add NewStr1, ws1.Cells(Row1.row, 1).Resize(, ws1.UsedRange.Columns.Count)
        End If
    End If
Next
For Each rng In MyDic.Items
    x = x + 1
    Debug.Print rng.Address
    If rng.Areas.Count > 1 Or rng.Rows.Count > 1 Then
        Set sht = ws1.Parent.Sheets.Add
        rc = 1
        sht.Name = "dup" & x
        For Each rw In rng.Rows
            sht.Cells(rc, 1).Resize(, rw.Columns.Count).Value = rw.Value
            rc = rc + 1
        Next
        rng.Delete xlShiftUp
    End If
Next
Application.ScreenUpdating = True
Set MyDic = Nothing
Set ws1 = Nothing

---

It's working but it moves each original and duplicate set of rows into a separate sheet but I want all the original and duplicate set of rows to be moved into one worksheet and name it as "Filtered Out data". the dup1, dup2 text which is used by you to name the worksheet is useful, can we enter the same text in the last column of "Filtered out data" worksheet instead. e.g. below snapshot.

Quote:

---

but I want all the original and duplicate set of rows to be moved into one worksheet and name it as "Filtered Out data"

---

i an sure by now you should be able to modify the code to achieve that result

Quote:

---

can we enter the same text in the last column of "Filtered out data" worksheet

---

that should also be very easy to do

I tried the below but it shows errors on the lines which are highlighted in bold and blue. instead I can use the combine sheets method post running the entire macro, but I think we don't need to use the combine sheets macro over here, it can be avoided and we can incorporate the logic in the main macro but I am not clear on how it can be achieved. Would appreciate if you can help.

Below is main macro slightly tweaked by me to attempt to copy all duplicate and original set of rows into one sheet .i.e. Filtered out data, but it shows a compile error: variable not defined if we retain option explicit on top and if I remove the option explicit then it shows Object required error on the next line which is highlighted bold and blue:

Code:

---

Option Explicit
Sub IdentifyDuplicatesandmove()

Dim ws1 As Worksheet
Dim Row1 As Range
Dim Col1 As Range
Dim NewStr1 As String
'Needs reference to Microsoft Scripting Runtime
Dim MyDic As Dictionary
Set MyDic = New Dictionary
Set ws1 = ActiveWorkbook.Sheets("Sheet2")
Application.ScreenUpdating = False
For Each Row1 In ws1.UsedRange.Rows
    'If rows are blank then skip
    If Application.CountA(ws1.Rows(Row1.row)) > 0 Then
        NewStr1 = "ws1.name"
        For Each Col1 In ws1.UsedRange.Columns
        NewStr1 = NewStr1 & "||" & CStr(ws1.Cells(Row1.row, Col1.Column))
        Next
        If MyDic.exists(NewStr1) Then
            Set rng = MyDic.Item(NewStr1)  ' Compile error: variable not defined
           
            Set rng = Union(rng, Cells(Row1.row, 1).Resize(, ws1.UsedRange.Columns.Count))
            Set MyDic.Item(NewStr1) = rng
            'Colour intra sheet duplicates in sheet 1 as blue
            ''ws1.Rows(Row1.row).Interior.Color = vbBlue
            ''ws1.Rows(MyDic(NewStr1)).Interior.Color = vbRed
            Else
            MyDic.Add NewStr1, ws1.Cells(Row1.row, 1).Resize(, ws1.UsedRange.Columns.Count)
        End If
    End If
Next
For Each rng In MyDic.Items
    x = x + 1
    Debug.Print rng.Address
    If rng.Areas.Count > 1 Or rng.Rows.Count > 1 Then
        Set sht = ws1.Parent.Sheets.Add
        rc = 1
        sht.Name = "Filtered Out Data"
     
          sht.Cells(rc, 1).Resize(, rw.Columns.Count).Value = rw.Value
            rc = rc + 1
   
        rng.Delete xlShiftUp
    End If
Next
Application.ScreenUpdating = True
Set MyDic = Nothing
Set ws1 = Nothing
End Sub

---

below is the combine sheet macro which can be run post running the original macro and it would work, but I believe it would be better if we add the logic in the main macro itself instead of first getting them in separate sheets and then combining.

Code:

---

Sub combineshts()
Dim i As Integer
    Dim xTCount As Variant
    Dim xWs As Worksheet
 
    xTCount = 1
   
    Set xWs = ActiveWorkbook.Worksheets.Add(Sheets(1))
    xWs.Name = "Filtered Out Data"
    Sheets("Sheet2").Range("A1").EntireRow.Copy Destination:=xWs.Range("A1")
   
    For i = 2 To Worksheets.Count
    For Each xWs In ThisWorkbook.Worksheets
      If xWs.Name <> "Pivot" And xWs.Name <> "Pivot2" And xWs.Name <> "Mapping" Then
      Worksheets(i).Range("A1").CurrentRegion.Offset(CInt(xTCount), 0).Copy _
      Destination:=xWs.Cells(xWs.UsedRange.Cells(xWs.UsedRange.Count).row + 1, 1)
      End If
    Next
    Next
    Application.DisplayAlerts = False
    For Each xWs In ActiveWorkbook.Sheets
    If Left(xWs.Name, 3) = "dup" Then
        xWs.Delete
    End If
Next xWs
Application.DisplayAlerts = True
End Sub

---

Code:

---

        If MyDic.exists(NewStr1) Then
            Set MyDic.Item(NewStr1) = union(MyDic.Item(NewStr1),Cells(Row1.row, 1).Resize(, ws1.UsedRange.Columns.Count))
            Else
            MyDic.Add NewStr1, ws1.Cells(Row1.row, 1).Resize(, ws1.UsedRange.Columns.Count)
        End If

---

you can replace the error part with as above

surly you would know by now that variable not defined means to dimension (dim) the variable

Code:

---

Set sht = ws1.Parent.Sheets.Add     
 sht.Name = "duplicates"
 rc = 1
For Each rng In MyDic.Items
    x = x + 1
    Debug.Print rng.Address
    If rng.Areas.Count > 1 Or rng.Rows.Count > 1 Then
        For Each rw In rng.Rows
            sht.Cells(rc, 1).Resize(, rw.Columns.Count).Value = rw.Value
            sht.offset(,rw.columns.count) = "dup" & x
            rc = rc + 1
        Next
        rng.Delete xlShiftUp
    End If
Next

---

the above code should put all the duplicates into the same sheet, with dup number
you will still need to define all additional variables, up to you to figure out what they are

Ok. I have updated the code by defining variables, but it seems something is going wrong. It shows compile error on the line highlighted in blue. Can you please help.

Code:

---

Option Explicit

Sub IdentifyDuplicatesandmovenew()

Dim ws1 As Worksheet
Dim Row1 As Range
Dim Col1 As Range
Dim NewStr1 As String
'Needs reference to Microsoft Scripting Runtime
Dim MyDic As Dictionary
Set MyDic = New Dictionary
Set ws1 = ActiveWorkbook.Sheets("Raw Data")
Application.ScreenUpdating = False
For Each Row1 In ws1.UsedRange.Rows
    'If rows are blank then skip
    If Application.CountA(ws1.Rows(Row1.Row)) > 0 Then
        NewStr1 = "ws1.name"
        For Each Col1 In ws1.UsedRange.Columns
        NewStr1 = NewStr1 & "||" & CStr(ws1.Cells(Row1.Row, Col1.Column))
        Next
      If MyDic.exists(NewStr1) Then
            Set MyDic.Item(NewStr1) = Union(MyDic.Item(NewStr1), Cells(Row1.Row, 1).Resize(, ws1.UsedRange.Columns.Count))
            Else
            MyDic.Add NewStr1, ws1.Cells(Row1.Row, 1).Resize(, ws1.UsedRange.Columns.Count)
        End If
    End If
Next
Dim sht As Worksheet
Dim rc As Integer
Dim rng As Range
Dim x As Integer
Dim rw As Range
Set sht = ws1.Parent.Sheets.Add
 sht.Name = "duplicates"
 rc = 1
For Each rng In MyDic.Items
    x = x + 1
    Debug.Print rng.Address
    If rng.Areas.Count > 1 Or rng.Rows.Count > 1 Then
        For Each rw In rng.Rows
            sht.Cells(rc, 1).Resize(, rw.Columns.Count).Value = rw.Value
            sht.Offset(, rw.Columns.Count) = "dup" & x ' Compile Error: Method or Data Member not found.
            rc = rc + 1
        Next
        rng.Delete xlShiftUp
    End If
Next

Application.ScreenUpdating = True
Set MyDic = Nothing
Set ws1 = Nothing

End Sub

---

i was in a bit of a hurry to finish, so did not test any of the updated code
should have been

Code:

---

sht.cells(rc,1),Offset(, rw.Columns.Count) = "dup" & x

---

Now it shows syntax error on the updated line (highlighted in blue)

Code:

---

Option Explicit

Sub IdentifyDuplicatesandmovenew()

Dim ws1 As Worksheet
Dim Row1 As Range
Dim Col1 As Range
Dim NewStr1 As String
'Needs reference to Microsoft Scripting Runtime
Dim MyDic As Dictionary
Set MyDic = New Dictionary
Set ws1 = ActiveWorkbook.Sheets("Raw Data")
Application.ScreenUpdating = False
For Each Row1 In ws1.UsedRange.Rows
    'If rows are blank then skip
    If Application.CountA(ws1.Rows(Row1.Row)) > 0 Then
        NewStr1 = "ws1.name"
        For Each Col1 In ws1.UsedRange.Columns
        NewStr1 = NewStr1 & "||" & CStr(ws1.Cells(Row1.Row, Col1.Column))
        Next
      If MyDic.exists(NewStr1) Then
            Set MyDic.Item(NewStr1) = Union(MyDic.Item(NewStr1), Cells(Row1.Row, 1).Resize(, ws1.UsedRange.Columns.Count))
            Else
            MyDic.Add NewStr1, ws1.Cells(Row1.Row, 1).Resize(, ws1.UsedRange.Columns.Count)
        End If
    End If
Next
Dim sht As Worksheet
Dim rc As Integer
Dim rng As Range
Dim x As Integer
Dim rw As Range
Set sht = ws1.Parent.Sheets.Add
 sht.Name = "duplicates"
 rc = 1
For Each rng In MyDic.Items
    x = x + 1
    Debug.Print rng.Address
    If rng.Areas.Count > 1 Or rng.Rows.Count > 1 Then
        For Each rw In rng.Rows
            sht.Cells(rc, 1).Resize(, rw.Columns.Count).Value = rw.Value
            sht.cells(rc,1),Offset(, rw.Columns.Count) = "dup" & x ' Compile Error: syntax error.
            rc = rc + 1
        Next
        rng.Delete xlShiftUp
    End If
Next

Application.ScreenUpdating = True
Set MyDic = Nothing
Set ws1 = Nothing

End Sub

---

oops
should be .offset

Now it shows Run time error '424' Object required on the line highlighted in blue.

Code:

---

Option Explicit

Sub IdentifyDuplicatesandmovenew()

Dim ws1 As Worksheet
Dim Row1 As Range
Dim Col1 As Range
Dim NewStr1 As String
'Needs reference to Microsoft Scripting Runtime
Dim MyDic As Dictionary
Set MyDic = New Dictionary
Set ws1 = ActiveWorkbook.Sheets("Raw Data")
Application.ScreenUpdating = False
For Each Row1 In ws1.UsedRange.Rows
    'If rows are blank then skip
    If Application.CountA(ws1.Rows(Row1.Row)) > 0 Then
        NewStr1 = "ws1.name"
        For Each Col1 In ws1.UsedRange.Columns
        NewStr1 = NewStr1 & "||" & CStr(ws1.Cells(Row1.Row, Col1.Column))
        Next
      If MyDic.exists(NewStr1) Then
            Set MyDic.Item(NewStr1) = Union(MyDic.Item(NewStr1), Cells(Row1.Row, 1).Resize(, ws1.UsedRange.Columns.Count))
            Else
            MyDic.Add NewStr1, ws1.Cells(Row1.Row, 1).Resize(, ws1.UsedRange.Columns.Count)
        End If
    End If
Next
Dim sht As Worksheet
Dim rc As Integer
Dim rng As Range
Dim x As Integer
Dim rw As Range
Set sht = ws1.Parent.Sheets.Add
 sht.Name = "duplicates"
 rc = 1
For Each rng In MyDic.Items
    x = x + 1
    Debug.Print rng.Address
    If rng.Areas.Count > 1 Or rng.Rows.Count > 1 Then
        For Each rw In rng.Rows
            sht.Cells(rc, 1).Resize(, rw.Columns.Count).Value = rw.Value
            sht.cells(rc,1).Offset(, rw.Columns.Count) = "dup" & x ' Compile Error: syntax error.
            rc = rc + 1
        Next
        rng.Delete xlShiftUp
    End If
Next

Application.ScreenUpdating = True
Set MyDic = Nothing
Set ws1 = Nothing

End Sub

---

for whatever reason, while rng variable does hold a range when the mydic item is assigned to it, it will only work if rng is of type variant, so dim rng as variant, or just dim rng

Got it. It works now. Thanks a lot. Appreciate it :)

Just one last thing, it creates the duplicates sheet, even when there are zero duplicates sometimes in the sheet. can we avoid created the duplicates sheet when there are no duplicates and show a msgbox. no duplicates found.

Code:

---

rc = 1
For Each rng In MyDic.Items
    x = x + 1
    Debug.Print rng.Address
    If rng.Areas.Count > 1 Or rng.Rows.Count > 1 Then
        if sht is nothing then
            Set sht = ws1.Parent.Sheets.Add
            sht.Name = "duplicates"
      end if
        For Each rw In rng.Rows
            sht.Cells(rc, 1).Resize(, rw.Columns.Count).Value = rw.Value
            sht.cells(rc,1).Offset(, rw.Columns.Count) = "dup" & x ' Compile Error: syntax error.
            rc = rc + 1
        Next
        rng.Delete xlShiftUp
    End If
Next
if sht is nothing then msgbox "No Duplicates Found"

---

try this one