如何突出显示具有不同颜色的多个重复列？

Question

我有 23 列数据，我的任务是突出显示（用不同颜色）重复的列。

例如：

在上面的示例中，Col A 和 C 将以一种颜色突出显示，而 Col 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