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

Question

我在 sheet 中的两列中有如下数据。

+------------------+---------------------------------------+
|       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.

中不存在

目前，我可以通过在单独的 sheet 中获取所有分号分隔值并将其用于匹配来实现。但它变得棘手，因为 B 中分号分隔值的数量不统一并且可能变化很大。

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

Answer 1

应该可行

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

Answer 2

试试这个：

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

演示：

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

Matching with a column containing character-delimited values in excel using VBA

excel

vba

matching