Как выделить несколько повторяющихся столбцов с разными цветами?

Question

У меня есть 23 столбца данных, и мне было поручено выделить (разными цветами) столбцы, которые являются дубликатами.

Например:

В приведенном выше примере столбцы A и C будут выделены одним цветом, а столбцы B и D будут выделены другим.Я попытался отредактировать приведенный ниже код (только выдвигает на первый план повторяющиеся значения В одном и том же столбце), чтобы выполнить то, что мне нужно, но безрезультатно.

Sub ColorCompanyDuplicates()
'Updateby Extendoffice 20160704
    Dim xRg As Range
    Dim xTxt As String
    Dim xCell As Range
    Dim xChar As String
    Dim xCellPre As Range
    Dim xCIndex As Long
    Dim xCol As Collection
    Dim I As Long
    On Error Resume Next
    If ActiveWindow.RangeSelection.Count > 1 Then
      xTxt = ActiveWindow.RangeSelection.AddressLocal
    Else
      xTxt = ActiveSheet.UsedRange.AddressLocal
    End If
    Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    xCIndex = 2
    Set xCol = New Collection
    For Each xCell In xRg
      On Error Resume Next
      xCol.Add xCell, xCell.Text
      If Err.Number = 457 Then
        xCIndex = xCIndex + 1
        Set xCellPre = xCol(xCell.Text)
        If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
        xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
      ElseIf Err.Number = 9 Then
        MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
        Exit Sub
      End If
      On Error GoTo 0
    Next
End Sub

Answer 1

если мое понимание вашего требования следующее Тогда можете попробовать

 Sub ColorCompanyDuplicates()
'Updateby Extendoffice 20160704
    Dim xRg As Range
    Dim xRng1 As Range
    Dim xRng2 As Range
    Dim xTxt As String
    Dim xCIndex As Long
    Dim Ws As Worksheet
    Dim I As Long, I2 As Long, FirstRow As Long, FirstCol As Long, LastRow As Long, LastCol As Long
    Dim MatchTrue As Boolean, MatchCount As Long

    Set Ws = ThisWorkbook.ActiveSheet
    With Ws

        If Selection.Count > 1 Then
        xTxt = Selection.AddressLocal
        Else
        xTxt = .UsedRange.AddressLocal
        End If

    xTxt = InputBox("please select the data range:", "Kutools for Excel", xTxt)

    On Error Resume Next
    Set xRg = .Range(xTxt)
    On Error GoTo 0

    If xRg Is Nothing Then Exit Sub
    xRg.Interior.ColorIndex = xlNone
    FirstRow = xRg.Row
    FirstCol = xRg.Column

    LastRow = FirstRow + xRg.Rows.Count - 1
    LastCol = FirstCol + xRg.Columns.Count - 1

    xCIndex = 2
    For I = FirstCol To LastCol
    'skips already re-colored columns
    If .Cells(FirstRow, I).Interior.ColorIndex = xlNone Then
    MatchCount = 0
        For I2 = I + 1 To LastCol
        MatchTrue = True
            For I3 = FirstRow To LastRow
                If .Cells(I3, I).Value <> .Cells(I3, I2).Value Then
                MatchTrue = False
                Exit For
                End If
            Next I3

            If MatchTrue Then
            MatchCount = MatchCount + 1
                If MatchCount = 1 Then
                xCIndex = xCIndex + 1
                .Range(.Cells(FirstRow, I), .Cells(LastRow, I)).Interior.ColorIndex = xCIndex
                End If
            .Range(.Cells(FirstRow, I2), .Cells(LastRow, I2)).Interior.ColorIndex = xCIndex
            End If
        Next I2

        If MatchCount > 0 Then
        'may remove the msgbox to avoid interruptions
        MsgBox MatchCount & " duplicate companies found!", vbCritical, "Kutools for Excel"
        End If
     End If
     Next I
  End With
End Sub