Hi all
I found this code in the web to compare two worksheets and delete duplicates.
I made some minor changes and it works decently, but I am stuck with this 2 things:
1- Exclude the headers
2- Analyze just not the column H, I need analyze the range from C to K, if all cells are identical in both sheets, delete duplicates (only the range C to K).
Any idea please? ray:
Thanks
I found this code in the web to compare two worksheets and delete duplicates.
I made some minor changes and it works decently, but I am stuck with this 2 things:
1- Exclude the headers
2- Analyze just not the column H, I need analyze the range from C to K, if all cells are identical in both sheets, delete duplicates (only the range C to K).
Any idea please? ray:
Thanks
Code:
Sub CleanDupes()
Dim targetArray, searchArray
Dim targetRange As Range
Dim x As Long
'Update these 4 lines if your target and search ranges change
Dim TargetSheetName As String: TargetSheetName = "Daily Data"
Dim TargetSheetColumn As String: TargetSheetColumn = "H"
Dim SearchSheetName As String: SearchSheetName = "Matches Added"
Dim SearchSheetColumn As String: SearchSheetColumn = "H"
Application.ScreenUpdating = False
'Load target array
With Sheets(TargetSheetName)
Set targetRange = .Range(.Range(TargetSheetColumn & "1"), .Range(TargetSheetColumn & Rows.Count).End(xlUp))
targetArray = targetRange
End With
'Load Search Array
With Sheets(SearchSheetName)
searchArray = .Range(.Range(SearchSheetColumn & "1"), .Range(SearchSheetColumn & Rows.Count).End(xlUp))
End With
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = 0
If IsArray(searchArray) Then
For x = 1 To UBound(searchArray)
If Not dict.exists(searchArray(x, 1)) Then
dict.Add searchArray(x, 1), 1
End If
Next
Else
If Not dict.exists(searchArray) Then
dict.Add searchArray, 1
End If
End If
'Delete rows with values found in dictionary
If IsArray(targetArray) Then
'Step backwards to avoid deleting the wrong rows.
For x = UBound(targetArray) To 1 Step -1
If dict.exists(targetArray(x, 1)) Then
'targetRange.Cells(x).EntireRow.Delete
targetRange.Cells(x).ClearContents
End If
Next
Else
If dict.exists(targetArray) Then
targetRange.EntireRow.ClearContents
End If
End If
Intersect([C:K], Columns("H").SpecialCells(xlBlanks).EntireRow).Delete xlUp
Application.ScreenUpdating = True
End Sub