正则重复查找判断

michaelaa

麻烦老师帮个忙,看一下,如何在复合单元格查找重复字符串,万分感谢!

cnmlgb9998

用PQ 没办法标红，但能找出结果。

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, j&, dic As Object, vKey
    Dim aMatch As Object, regEx As Object, Matches As Object
   
    Application.ScreenUpdating = False
   
    Set dic = CreateObject("Scripting.Dictionary")
   
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Global = True
   
    With [A1].CurrentRegion
        ar = .Value
        .Font.Color = 0
        For i = 2 To UBound(ar)
            br = Split(ar(i, 1), vbLf)
            For j = 0 To UBound(br)
                If Len(br(j)) Then dic(br(j)) = dic(br(j)) + 1
            Next j
        Next i
        For i = 2 To UBound(ar)
            With .Cells(i, 1)
                For Each vKey In dic.keys
                    If dic(vKey) > 1 Then
                        regEx.Pattern = vKey
                        Set Matches = regEx.Execute(ar(i, 1))
                        For Each aMatch In Matches
                            .Characters(Start:=aMatch.firstindex + 1, Length:=aMatch.Length).Font.ColorIndex = 3
                        Next
                    End If
                Next
            End With
        Next i
    End With
   
    Set dic = Nothing
    Set aMatch = Nothing
    Set Matches = Nothing
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

。。。。。。。。。。。。。

quqiyuan

参与一下，没有使用正则，供参考。。。

limonet

关键字：UBound+Filter

limonet

Sub limonet()
    Dim i%, j%, Arr As Variant, Cs As New Collection
    j = Range("A" & Rows.Count).End(xlUp).Row
    Arr = Split(Join(Application.Transpose(Range("A2:A" & j)), Chr(10)), Chr(10))
    For i = 0 To UBound(Arr)
        If Arr(i) <> "" And UBound(Filter(Arr, Arr(i))) > 0 Then
            Cs.Add Arr(i)
        End If
    Next i
    For i = 2 To j
        For j = 1 To Cs.Count
            Cells(i, "B").Characters(InStr(Cells(i, "B"), Cs(j)), Len(Cs(j))).Font.Color = vbBlue
            Cells(i, "B").Characters(InStr(Cells(i, "B"), Cs(j)), Len(Cs(j))).Font.Bold = True
        Next j
    Next i
End Sub