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

Question

我从某人那里获得了以下宏，并尝试对其进行修改以适合我的目的。

我正在尝试更改此宏以查找并突出显示每个单元格中具有重复值的单元格， 例如，它应该突出显示 B62 和 B63（绿色）， 并将重复值设置为红色（即 B62 中的 B_HWY_1010 和 B63 中的 B_HWY_1015）

Sub Dupes()
  Dim d As Object
  Dim a As Variant, itm As Variant
  Dim i As Long, k As Long
  Dim rng As Range
  Dim bColoured As Boolean
 
  Set d = CreateObject("Scripting.Dictionary")
  Set rng = Range("B1", Range("B" & Rows.Count).End(xlUp))
  a = rng.Value
  For i = 1 To UBound(a)
    For Each itm In Split(a(i, 1), ",")
      d(itm) = d(itm) + 1
    Next itm
  Next i
  Application.ScreenUpdating = False
  For i = 1 To UBound(a)
    k = 1
    bColoured = False
    For Each itm In Split(a(i, 1), ",")
      If d(itm) > 1 Then
        If Not bColoured Then
          rng.Cells(i).Interior.Color = vbGreen
          bColoured = True
        End If
        rng.Cells(i).Characters(k, Len(itm)).Font.Color = RGB(244, 78, 189)
      End If
      k = k + Len(itm) + 1
    Next itm
  Next i
  Application.ScreenUpdating = True
End Sub

感谢任何帮助或建议。

Answer 1

下面会这样做

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

以下项目将被着色：

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

Answer 2

请也尝试下一个代码：

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 来获得要处理的单元格。代码可以改编成这种关联，但是我现在懒得做...:)