VBA Code To Search Duplicates From Sheets1-2-3 And Paste In

[raindrop]

Hi,
I Have To Fight With Duplicate Cells Across Multiple Worksheets. Herewith I Have Attached A Just Example File To Workout With Mine...I Want VBA Code First To Search Duplicate Cells In Sheet1,Sheet2 And Sheet3 And Then Cut-Paste In Sheet "Duplicates" With Removing Empty Cells Shifting It Up In Related Column. Is There Any Help?

Thanks
Raindrop

[Rudi]

Hi Raindrop,

Can I clarify?
Do you want to check for a duplicate name within each individual list and move that duplicate name to the Duplicates sheet?
OR
Do you want to check for a duplicate name if it occurs within any of the lists across all three sheets, and only then move that name to the Duplicates sheet?

TX

[HansV]

The easiest way to remove duplicates would be to merge the lists into one long list and then to use the built-in Remove Duplicates command.

[raindrop]

Sir,
Actually duplicate I meant a whole content (not partial) of cell like it could be a full address with street name-number etc that if found in any other sheet (i.e. resembling cell), i want to move them leaving first entry, so names I used just for test.

Thanks & Regards
Raindrop

[HansV]

Could you post a version of your sample workbook that shows the desired result after moving the duplicates?

[Rudi]

Try this set of macros.
Only run the macro called: RemoveDuplicates
Also note that the code will only work across 3 sheets of duplicate data.

Code: Select all

Option Explicit

Sub RemoveDuplicates()

'============================================
'Note: This master macro runs the others
'============================================

    Application.ScreenUpdating = False
    DeDup1
    DeDup2
    Cleanup
    Application.ScreenUpdating = True
End Sub

'=========================================
Private Sub DeDup1()
Dim rData As Range
Dim i As Long, sh As Worksheet
    Application.ScreenUpdating = False
    For Each sh In Worksheets
        If sh.Name = "Duplicates" Then GoTo Skip
        Set rData = sh.Range("A2", sh.Range("A" & Rows.Count).End(xlUp))
        For i = rData.Rows.Count To 2 Step -1
            If Application.WorksheetFunction.CountIf(rData, Cells(i, "A")) > 1 Then
                Rows(i).EntireRow.Cut Destination:=Sheets("Duplicates").Range("A" & Rows.Count).End(xlUp).Offset(1)
                Rows(i).EntireRow.Delete
            End If
        Next i
Skip:
    Next sh
    Application.ScreenUpdating = True
End Sub

'=========================================
Private Sub DeDup2()
Dim WorkRng1 As Range, WorkRng2 As Range, WorkRng3 As Range
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range
Dim rngValue

'============================================
'Note: Only designed to run across 3 sheets
'============================================

    Application.ScreenUpdating = False
    Set WorkRng1 = Worksheets(1).Range("A2", Worksheets(1).Range("A" & Rows.Count).End(xlUp))
    Set WorkRng2 = Worksheets(2).Range("A2", Worksheets(2).Range("A" & Rows.Count).End(xlUp))
    Set WorkRng3 = Worksheets(3).Range("A2", Worksheets(3).Range("A" & Rows.Count).End(xlUp))
    For Each Rng1 In WorkRng1
        rngValue = Rng1.Value
        For Each Rng2 In WorkRng2
            If rngValue = Rng2.Value Then
                Rng1.Interior.Color = vbRed
                Exit For
            End If
            For Each Rng3 In WorkRng3
                If rngValue = Rng3.Value Then
                    Rng1.Interior.Color = vbRed
                    Exit For
                End If
            Next
        Next
    Next
    For Each Rng2 In WorkRng2
        rngValue = Rng2.Value
        For Each Rng3 In WorkRng3
            If rngValue = Rng3.Value Then
                Rng2.Interior.Color = vbRed
                Exit For
            End If
            For Each Rng1 In WorkRng1
                If rngValue = Rng1.Value Then
                    Rng2.Interior.Color = vbRed
                    Exit For
                End If
            Next
        Next
    Next
    For Each Rng3 In WorkRng3
        rngValue = Rng3.Value
        For Each Rng1 In WorkRng1
            If rngValue = Rng1.Value Then
                Rng3.Interior.Color = vbRed
                Exit For
            End If
            For Each Rng2 In WorkRng2
                If rngValue = Rng2.Value Then
                    Rng3.Interior.Color = vbRed
                    Exit For
                End If
            Next
        Next
    Next
    Application.ScreenUpdating = True
End Sub

'=========================================
Private Sub Cleanup()
Dim sh As Worksheet, rData As Range, i As Long
    Application.ScreenUpdating = False
    For Each sh In Worksheets
        If sh.Name = "Duplicates" Then GoTo Skip
        Set rData = sh.Range("A2", sh.Range("A" & Rows.Count).End(xlUp))
        For i = rData.Rows.Count To 1 Step -1
            If rData.Cells(i).Interior.Color = vbRed Then
                rData.Cells(i).EntireRow.Cut Destination:=Sheets("Duplicates").Range("A" & Rows.Count).End(xlUp).Offset(1)
            End If
        Next i
        On Error Resume Next
        sh.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        On Error GoTo 0
Skip:
    Next sh
    Worksheets("Duplicates").Range("A2", Worksheets("Duplicates").Range("A" & Rows.Count).End(xlUp)).Cells.Interior.ColorIndex = xlNone
    Worksheets(1).Select
    Application.ScreenUpdating = True
End Sub

[raindrop]

Thank You Rudi Sir,
Actually I Want To Move Only Duplicate Entries Throughout Sheets1-2-3 Leaving Only One Entry In Throughout Sheets1-2-3, e.g. If Stella Found In Sheet1,Sheet2 And Sheet3 Then Two Of Them Should Be Moved In Sheet-Duplicates.
I Apologize, I Could Not Justify My Question.

Thanks & Regards
Raindrop

[Rudi]

Over how many sheets do you need a check for duplicate names?

This is a strange request? Based on your description above it could be done by using Hans's suggestion a few posts up. Add all the data to one list, filter that list for unique values, and then split the list back over the amount of sheets (in equal proportions (if necessary)). This will be FAR easier than searching for duplicates across multiple sheets.

[raindrop]

Hi !
Actually 9 Sheets.

Thanks & Regards
Raindrop

[Rudi]

Its not the most elegant of code, but try this...

Please note:
The Duplicates sheet MUST be called Duplicates and MUST be at the end of the Workbook (the last sheet)

Code: Select all

Sub SplitDuplicates()
Dim i As Integer, lRC As Long, rData As Range
    Application.ScreenUpdating = False
    
    Worksheets.Add before:=Worksheets(1)
    Worksheets.Add before:=Worksheets(1)
    For i = 3 To Worksheets.Count - 1
        Worksheets(i).Activate
        Range("A2", Range("A" & Rows.Count).End(xlUp)).Copy
        Worksheets(1).Activate
        Worksheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial
        Selection.Offset(0, 1).Value = Worksheets(i).Name
        Worksheets(i).Activate
        Worksheets(i).Range("A2", Range("A" & Rows.Count).End(xlUp)).Clear
    Next i
    Worksheets(1).Activate
    Range("A1:C1").Value = Array("Names", "Sheet", "Counts")
    lRC = Range("A1", Range("A" & Rows.Count).End(xlUp)).Rows.Count
    Range("A2", Range("A" & Rows.Count).End(xlUp)).Offset(0, 2).Formula = "=COUNTIF(RC[-2]:R" & lRC & "C1,RC[-2])"
    Range("A1").CurrentRegion.Columns(1).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Range("A1").CurrentRegion.Copy Worksheets(2).Range("A1")
    ActiveSheet.ShowAllData
    
    Worksheets(2).Activate
    For i = 3 To Worksheets.Count - 1
    Range("A1").CurrentRegion.AutoFilter Field:=2, Criteria1:=Worksheets(i).Name
    Range("A1").CurrentRegion.Columns(1).Offset(1).Copy Worksheets(i).Range("A2")
    ActiveSheet.ShowAllData
    Next i
    
    Worksheets(1).Activate
    Range("A1").CurrentRegion.AutoFilter Field:=3, Criteria1:=">1"
    Range("A1").CurrentRegion.Columns(1).Offset(1).Copy Worksheets("Duplicates").Range("A2")
    ActiveSheet.ShowAllData
    
    Application.DisplayAlerts = False
    Worksheets(Array(1, 2)).Delete
    
    Application.ScreenUpdating = True
    MsgBox "Macros finished processing. Duplicates are moved to Sheet: Duplicates.", vbInformation

End Sub

[raindrop]

Rudy Sir,
Thank You Very Much. Your Code Worked Successful For My Work.

Thanks & Regards
Raindrop