Removing Duplicates with in the worksheet

Hello All,

I had asked by someone to create a code for removing a duplicate from worksheets.

The requirement was such that one keyword should only appears once in Column B in all the worksheets. So if a value (for example "Data-1234") appears in sheet 1 in column B, then it cannot appear again in Column B, in any of the worksheets. If it appears, then move it to Duplicate sheet.

So I used the following code. Thought it might be a help so posting it here. To make it work, you will need to add a reference to Microsoft Scripting Runtime.

Const ColumnToSearch As String = "B"

Const ColumnToSearch_i As Integer = 2

Private duplicates As Scripting.Dictionary



Sub MoveDuplicates()



    Dim blankCounter As Integer

    Dim rowCounter As Long

    Dim duplicate As Worksheet

    Dim sht As Worksheet

    Dim runLoop As Boolean

    Dim value As String

    Dim added As Boolean

    Dim lastRow As Long

    

    runLoop = True

    

    

    Set duplicates = New Scripting.Dictionary

    

    

    Set duplicate = GetWorksheet(ActiveWorkbook, "DuplicateEntries")

    

    If (duplicate Is Nothing) Then

        Set duplicate = ActiveWorkbook.Worksheets.Add

        duplicate.name = "DuplicateEntries"

    End If

    

    

    'get duplicate sheet

    

    For Each sht In ActiveWorkbook.Worksheets

        

        blankCounter = 1

        rowCounter = 2

        runLoop = True

        

        

        

        

        If (sht.name <> "DuplicateEntries") Then

            

            lastRow = GetLastRow(duplicate, 1)

            

            If (lastRow > 1) Then

                lastRow = lastRow + 2

            End If

            

            'enter the log

            

            duplicate.Range("A" & lastRow).value = "Duplicate Entries Entered on : " & Now & " from Worksheet " & sht.name

            duplicate.Range("A" & lastRow + 1).value = "'-"

            duplicate.Range("A" & lastRow + 2).value = "'-"

            

            

            

            

            While runLoop

                If (blankCounter > 10) Then

                    runLoop = False

                Else

                    'check blank

                    

                    value = Trim(sht.Cells(rowCounter, ColumnToSearch_i).value)

                    

                    

                    If (value = "") Then

                        blankCounter = blankCounter + 1

                    Else

                        blankCounter = 1

                        added = AddSuccess(value)

                        lastRow = GetLastRow(duplicate, 1) + 1

                        If (added) Then

                             'dont do anything. not a duplicate

                        Else

                            'Duplicate item, Move

                            MoveRow sht.Cells(rowCounter, ColumnToSearch_i), duplicate.Cells(lastRow, 1)

                            rowCounter = rowCounter - 1

                        End If

                        

                    End If

                    

                    

                End If

                

                rowCounter = rowCounter + 1

                

            Wend

        End If

    Next sht

    

    

End Sub



Private Function GetLastRow(sht As Worksheet, Optional Col As Integer = 1) As Long

    Dim rng As Range

    

    GetLastRow = sht.Cells(sht.Rows.Count - 1, Col).End(xlUp).Row

    

End Function



Private Function GetWorksheet(wkb As Workbook, shtName As String) As Worksheet

    Dim sht As Worksheet

    

    On Error Resume Next

        Set GetWorksheet = wkb.Worksheets(shtName)

    Err.Clear

    

End Function



Private Sub MoveRow(rngToMove As Range, moveAt As Range)

    rngToMove.EntireRow.Copy moveAt

    rngToMove.EntireRow.Delete

End Sub



Private Function AddSuccess(name As String) As Boolean

    Err.Clear

    On Error Resume Next

        duplicates.Add name, name

            

        If (Err.Description <> "") Then

            AddSuccess = False

        Else

            AddSuccess = True

        End If

            

    Err.Clear

End Function

HTH,
Vikas