Excel Duplicate Finder в отдельных столбцах

Question

Я нашел этот кусок кода в сети и попытался изменить его, чтобы сделать то, что я хочу. Он работает очень простым способом c, когда вы назначаете его в качестве макроса для кнопки формы, чтобы найти дубликаты в 6 отдельных столбцах, но есть ли способ привести в порядок код и, возможно, автоматизировать его, поэтому я не буду не нужно каждый раз нажимать кнопку формы для запуска макроса?

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

Некоторые другие способы автоматизации макроса - это события WorkSheet_Change и Workbook_Open, но я бы остановился на Button_Click для запуска макроса. Приведенный ниже код может быть использован для l oop через диапазон в каждом столбце и дублировать значения цветов с помощью AutoFilter. Если вы хотите покрасить каждую группу другим цветом, вы можете использовать рандомизированную строку кода RGB.

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