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

Posted 2023-03-29

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

【英文标题】：Trying to find Duplicate comma delimited texts in each cell of a column

【发布时间】：2021-07-28 18:36:36

【问题描述】：

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

我正在尝试更改此宏以查找并突出显示每个单元格中具有重复值的单元格， 例如，它应该突出显示 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

感谢任何帮助或建议。

【问题讨论】：

“重复的逗号分隔文本”是什么意思？只有一个分隔元素与另一个单元格中的另一个元素相同？还是整个字符串，即使它包含逗号分隔符也是一样的？

@FaneDuru 简而言之，我试图在单个单元格中查找重复项，而不是与任何其他单元格进行比较。因此，如果您查看帖子中的图像，第 62 行有一个输入两次的值，用逗号分隔，所以在这种情况下，我希望宏能够识别它并突出显示它

如果有两个这样的相同字符串（在一个单元格中）而第三个不同呢？会被标记为重复吗？

@FaneDuru 是的，它也必须识别这一点。假设一个单元格有：A、B、C、B，那么它应该识别并突出显示第二个“B”

突出显示第二个“B”，还是讨论中的单元格？你图片中的绿色内部颜色是什么意思？

【参考方案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 作为第一行来防止。

【讨论】：

很好...投了赞成票。我知道他希望这两个事件都加粗。

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

【讨论】：

干得好，看起来也可以。它只是为第一次重复着色。而是留下第一个黑色并为其他颜色着色，它为第一个着色并留下最后一个黑色。 • 他说A, B, C, B then it should identify and highlight the 2nd "B" 你的颜色是第一个B 而不是第二个。 • 但实际上很高兴将两种方式都包含在答案中。

好极了，这个也很好用。谢谢你们俩

未优化，仅测试过一次，它适用于我的样本，没有尝试过不同的变体，现在我正在开车...... :)

@Pᴇʜ：更改了代码逻辑，以便将所有重复出现的地方都涂成红色。

@M Muaz：更改了代码逻辑，以便将所有重复的事件都涂成红色。它也应该足够快，适用于大范围。