Friday, August 26, 2011

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 = "DuplicateEntries"
End If

'get duplicate sheet

For Each sht In ActiveWorkbook.Worksheets

blankCounter = 1
rowCounter = 2
runLoop = True

If ( <> "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 " &
duplicate.Range("A" & lastRow + 1).value = "'-"
duplicate.Range("A" & lastRow + 2).value = "'-"

While runLoop
If (blankCounter > 10) Then
runLoop = False
'check blank

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

If (value = "") Then
blankCounter = blankCounter + 1
blankCounter = 1
added = AddSuccess(value)
lastRow = GetLastRow(duplicate, 1) + 1
If (added) Then
'dont do anything. not a duplicate
'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

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)

End Function

Private Sub MoveRow(rngToMove As Range, moveAt As Range)
rngToMove.EntireRow.Copy moveAt
End Sub

Private Function AddSuccess(name As String) As Boolean
On Error Resume Next
duplicates.Add name, name

If (Err.Description <> "") Then
AddSuccess = False
AddSuccess = True
End If

End Function


No comments: