尝试在列的每个单元格中查找重复的逗号分隔文本

下面将执行此操作

Option Explicit

Public Sub Example()
    Dim Cell As Range
    For Each Cell In Range("A1:A10")
        HighlightRepetitions Cell, ", "
    Next Cell
End Sub

Private Sub HighlightRepetitions(ByVal Cell As Range, ByVal Delimiter As String)
    If Cell.HasFormula Or Cell.HasArray Then Exit Sub ' don't run on formulas

    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    
    Dim Data() As String
    Data = Split(Cell.Value, Delimiter)  ' split data in the cell by Delimiter 
    
    Dim StrLen As Long  ' length of the string that was already processed
    
    Dim i As Long
    For i = LBound(Data) To UBound(Data)  ' loop through all data items
        Dim DataLen As Long
        DataLen = Len(Data(i))  'get length of current item
        
        If Dict.Exists(Data(i)) Then
            ' item is a repetition: color it
            Cell.Characters(StrLen + 1, DataLen).Font.Color = vbRed
            Cell.Interior.Color = vbGreen
        Else
            ' item is no repetition: add it to the dictionary
            Dict.Add Data(i), Data(i)
        End If
        
        StrLen = StrLen + DataLen + Len(Delimiter)  ' calculate the length of the processed string and add length of the delimiter
    Next i
End Sub

以下项目将着色：

您可以在循环之前关闭，并在循环之后打开以阻止其闪烁。请注意，这不会在 formuas 上运行，因为部分公式结果不能着色。这可以通过用作第一行来防止。ScreenUpdatingSub Example()If Cell.HasFormula Or Cell.HasArray Then Exit Sub

请也尝试下一个代码：

Sub findComaDelDuplicates()
 Dim sh As Worksheet, arr, itm, arrInt, i As Long, rngS As Range, pos As Long
 Dim arrDif As Long, j As Long, startPos As Long, arrPos, k As Long, mtch
 
 Set sh = ActiveSheet
 With sh.Range("B1", Range("B" & sh.rows.count).End(xlUp))
    arr = .value               'put the range value in an array to make the iteration faster
    .ClearFormats            'clear previous format
    .Font.Color = vbBlack 'make the font color black
 End With
 
 For i = 1 To UBound(arr)           'iterate between the array elements:
    arrInt = Split(arr(i, 1), ",")       'split the content by comma delimiter
    ReDim arrPos(UBound(arrInt)) 'redim the array keeping elements already formatted
    For Each itm In arrInt            'iterate between the comma separated elements
        arrDif = UBound(arrInt) - 1 - UBound(Filter(arrInt, itm, False)) 'find how many times an element exists
        If arrDif > 0 Then            'if more then an occurrence:
            If rngS Is Nothing Then             'if range to be colored (at once) does not exist:
                Set rngS = sh.Range("B" & i)  'it is crated
            Else
                Set rngS = Union(rngS, sh.Range("B" & i)) 'a union is made from the previous range and the new one
            End If
            mtch = Application.match(itm, arrPos, 0)       'check if the itm was already processed:
            If IsError(mtch) Then                                'if itm was not processed:
                For j = 1 To arrDif + 1                          'iterate for number of occurrences times
                    If j = 1 Then startPos = 1 Else: startPos = pos + 1 'first time, inStr starts from 1, then after the first occurrence
                    pos = InStr(startPos, sh.Range("B" & i).value, itm)  'find first character position for the itm to be colored
                    sh.Range("B" & i).Characters(pos, Len(itm)).Font.Color = vbRed 'color it
                Next j
                arrPos(k) = itm      'add the processed itm in the array
            End If
        End If
    Next
    Erase arrInt                      'clear the array for the next cell value
 Next i
 If Not rngS Is Nothing Then rngS.Interior.Color = vbGreen        'color the interior cells of the built range
End Sub

注意：上面的代码将范围放在数组中，以便更快地迭代。但是，如果区域不是从第一行开始的，则必须通过将行添加到区域的第一行来获取要处理的单元格。代码可以调整以建立这种关联，但我现在懒得这样做......:)i