Excel Duplicate Finder in Seperate Columns - excel

Question

I've found this piece of code online and tried to modify it to do what i want. It works in a very basic way, where you assign it as a macro to a Form button, to find duplicates in 6 seperate columns, but is there a way of tidying up the code, and possibly automating it, so i don't have to press a form button to run the macro every time ?
Sub Check_Dups()
'Declaring variables
Dim Cell As Variant
Dim Source As Range
Dim Source2 As Range
Dim Source3 As Range
Dim Source4 As Range
Dim Source5 As Range
Dim Source6 As Range
'Initializing source range
Set Source = Range("E8:E105")
Set Source2 = Range("F8:F105")
Set Source3 = Range("G8:G105")
Set Source4 = Range("H8:H105")
Set Source5 = Range("I8:I105")
Set Source6 = Range("J8:J105")
'Removing any previous formatting from the source
Source.Interior.Color = RGB(255, 255, 255)
Source2.Interior.Color = RGB(255, 255, 255)
Source3.Interior.Color = RGB(255, 255, 255)
Source4.Interior.Color = RGB(255, 255, 255)
Source5.Interior.Color = RGB(255, 255, 255)
Source6.Interior.Color = RGB(255, 255, 255)
'Looping through each cell in the source range
For Each Cell In Source
'Checking whether value in cell already exist in the source range
If Application.WorksheetFunction.CountIf(Source, Cell) > 1 Then
'Highlighting duplicate values in red color
Cell.Interior.Color = RGB(255, 0, 0)
End If
Next
'Looping through each cell in the source range
For Each Cell In Source2
'Checking whether value in cell already exist in the source range
If Application.WorksheetFunction.CountIf(Source2, Cell) > 1 Then
'Highlighting duplicate values in red color
Cell.Interior.Color = RGB(255, 0, 0)
End If
Next
'Looping through each cell in the source range
For Each Cell In Source3
'Checking whether value in cell already exist in the source range
If Application.WorksheetFunction.CountIf(Source3, Cell) > 1 Then
'Highlighting duplicate values in red color
Cell.Interior.Color = RGB(255, 0, 0)
End If
Next
'Looping through each cell in the source range
For Each Cell In Source4
'Checking whether value in cell already exist in the source range
If Application.WorksheetFunction.CountIf(Source4, Cell) > 1 Then
'Highlighting duplicate values in red color
Cell.Interior.Color = RGB(255, 0, 0)
End If
Next
'Looping through each cell in the source range
For Each Cell In Source5
'Checking whether value in cell already exist in the source range
If Application.WorksheetFunction.CountIf(Source5, Cell) > 1 Then
'Highlighting duplicate values in red color
Cell.Interior.Color = RGB(255, 0, 0)
End If
Next
'Looping through each cell in the source range
For Each Cell In Source6
'Checking whether value in cell already exist in the source range
If Application.WorksheetFunction.CountIf(Source6, Cell) > 1 Then
'Highlighting duplicate values in red color
Cell.Interior.Color = RGB(255, 0, 0)
End If
Next
End Sub

Answer 1

Some other ways to automate a macro are WorkSheet_Change and Workbook_Open events, but I would stick with Button_Click to initiate your macro.
The below code can be use to loop through the range in each column and color duplicate values using AutoFilter. If you want to color each group a different color, you can use the randomized RGB line of code.
Sub ColorDuplicates_wRGB()
'This macro loops thru each cell, if the cell has duplicates in the range, it filters the range using the cell value,
'then colors the visible cells in the range Red or with a unique color using RGB Colors.
'xlNone in the If statement, skips previous colored cells.
'Works with both sorted and unsorted data.
Dim ws As Worksheet, rng As Range, cel As Range, colr As String, i As Long 'Define your variables
Application.ScreenUpdating = False 'I hate to see the screen flickering
Set ws = ThisWorkbook.Sheets("Sheet1") 'identify the worksheet variable; you will need to change the sheet reference
For i = 5 To 9 'To loop through each column
Set rng = ws.Range(ws.Cells(8, i), ws.Cells(105, i))
rng.Interior.ColorIndex = xlNone 'clear interior color for all cells in range
For Each cel In rng 'Loop
If WorksheetFunction.CountIf(rng, cel.Value) > 1 And cel.Interior.ColorIndex = xlNone Then
'Filter using cel.Value
rng.AutoFilter field:=1, Criteria1:=cel.Value
colr = RGB(255, 0, 0)
'If you want different colors for each duplicate group use the next line
'colr = RGB(Int((255 - 1 + 1) * Rnd() + 1), Int((255 - 1 + 1) * Rnd() + 1), Int((255 - 1 + 1) * Rnd() + 1))
'Select the visible cells in range and color, the -1 removes the blank row at the end caused by Offset
rng.Offset(1).Resize(rng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Interior.Color = colr
rng.AutoFilter 'reset filter
End If
Next cel
Next i
Application.ScreenUpdating = True
End Sub