使用 VBA 在 excel 中匹配包含字符分隔值的列

Question

我在工作表的两列中有如下数据。

+------------------+---------------------------------------+
|       A          |                  B                    |
+------------------+---------------------------------------+
| Hector Hall      |                                       |
| Guy Gardner      |                                       |
| Bart Allen       |                                       |
| Kyle Rayner      |                                       |
| Dick Grayson     |                                       |
| Khalid Nassour   |                                       |
| Kent Nelson      |                                       |
| Tim Drake        |                                       |
| Bat 2            | Dick Grayson; James Gordon            |
| James Gordon     |                                       |
| Hal Jordan       |                                       |
| Robin 2          | Tim Drake; Stephanie Brown            |
| Jay Garrick      |                                       |
| Jason Todd       |                                       |
| Flash 1          | Barry Allen; Wally West               |
| GL 2             | Guy Gardner; Kyle Rayner; Jon Stewart |
| Fate 1           | Kent Nelson; Khalid Nassour           |
| GL 1             | Alan Scott; Simon Baz                 |
| Simon Baz        |                                       |
| Robin 1          | Dick Grayson; Damien Wayne            |
| Alan Scott       |                                       |
| Bruce Wayne      |                                       |
| Jean Paul Valley |                                       |
| Wally West       |                                       |
| Bat 1            | Bruce Wayne; Jean Paul Valley         |
+------------------+---------------------------------------+

我正在尝试使用 VBA 代码创建一个 ActiveX 命令按钮，该代码执行以下条件格式：

1) 突出显示 A 中所有在 B 中以分号分隔值存在的单元格。

2) 突出显示 B 中分号分隔的值在 A 中不存在的所有单元格。

目前，我可以通过在单独的工作表中获取所有分号分隔的值并使用它进行匹配来做到这一点。但由于 B 中的分号分隔值的数量不统一，并且可能变化很大，因此变得很棘手。

在 excel VBA 中有更优雅的方法吗？

Answer 1

试试这个：

Sub rrrrr()

    Dim dicA As Object: Set dicA = CreateObject("Scripting.Dictionary")
    Dim dicB As Object: Set dicB = CreateObject("Scripting.Dictionary")
    Dim lastRow&, cl As Range, key$, keyA, keyB, x

    With ActiveSheet 'replace with source

        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        'get dictionary for column A
        For Each cl In .Range(.[A1], .Cells(lastRow, "A"))
            If Trim(cl.Value2) <> "" Then
                key = Trim(cl.Value2)
                If Not dicA.exists(key) Then
                    dicA.Add key, cl.Address(0, 0)
                Else
                    dicA(key) = dicA(key) & "," & cl.Address(0, 0)
                End If
            End If
        Next cl

        'get dictionary for column B
        For Each cl In .Range(.[B1], .Cells(lastRow, "B"))
            If Trim(cl.Value2) <> "" Then
                For Each x In Split(cl.Value2, ";")
                    key = Trim(x)
                    If Not dicB.exists(key) Then
                        dicB.Add key, cl.Address(0, 0)
                    Else
                        dicB(key) = dicB(key) & "," & cl.Address(0, 0)
                    End If
                Next x
            End If
        Next cl

        'keys in A not exist in B
        For Each keyA In dicA
            If Not dicB.exists(keyA) Then
                .Range(dicA(keyA)).Interior.Color = vbYellow
            End If
        Next keyA

        'keys in B not exist in A, and add comment what exact key not exists in B
        For Each keyB In dicB
            If Not dicA.exists(keyB) Then
                With .Range(dicB(keyB))
                    .Interior.Color = vbYellow
                    .ClearComments: .AddComment:
                    With .Comment
                        .Text "missed: " & keyB
                        .Shape.TextFrame.AutoSize = 1
                        .Shape.TextFrame.Characters.Font.Bold = 1
                        .Shape.Fill.ForeColor.RGB = RGB(58, 82, 184)
                        .Shape.AutoShapeType = msoShapeRoundedRectangle
                        .Shape.TextFrame.Characters.Font.ColorIndex = 2
                    End With
                End With
            End If
        Next keyB

    End With
End Sub

演示：

Answer 2

应该可以的

1)

Sub butA()

Dim szyt2 As Worksheet
Dim j As Long, i As Long, k As Long
Dim lastRow As Long
Dim araj1
Dim araj2

Set szyt2 = ThisWorkbook.Sheets("Sheet2")
lastRow = szyt2.Cells(Rows.Count, 1).End(xlUp).row
araj1 = szyt2.Range("A1:A" & lastRow).Value
araj2 = szyt2.Range("B1:B" & lastRow).Value

For i = 1 To UBound(araj2, 1)
    If Not (araj2(i, 1) = "") Then
        If InStr(1, araj2(i, 1), ";") > 0 Then
            ar = Split(araj2(i, 1), ";")
            For k = 0 To UBound(ar)
                For j = 1 To UBound(araj1, 1)
                    If araj1(j, 1) = ar(k) Then
                        szyt2.Cells(j, 1).Interior.ColorIndex = 3
                    End If
                Next
            Next
        End If
    End If
Next

End Sub

2)

Sub butB()

Dim szyt2 As Worksheet
Dim j As Long, i As Long, k As Long
Dim lastRow As Long
Dim araj1
Dim araj2

Set szyt2 = ThisWorkbook.Sheets("Sheet2")
lastRow = szyt2.Cells(Rows.Count, 1).End(xlUp).row
araj1 = szyt2.Range("A1:A" & lastRow).Value
araj2 = szyt2.Range("B1:B" & lastRow).Value
counter = 0

For i = 1 To UBound(araj2, 1)
    If Not (araj2(i, 1) = "") Then
        If InStr(1, araj2(i, 1), ";") > 0 Then
            ar = Split(araj2(i, 1), ";")
            For k = 0 To UBound(ar)
                For j = 1 To UBound(araj1, 1)
                    If araj1(j, 1) = ar(k) Then
                        counter = counter + 1
                    End If
                Next
                If counter > 0 Then Exit For
            Next
            If counter > 0 Then
                szyt2.Cells(i, 2).Interior.ColorIndex = 3
            End If
        End If
    End If
    counter = 0
Next

End Sub