Question

我正在处理一个通过2列（B＆amp; C）＆amp;突出显示合并单元格之间不同的单个部件号。那部分工作正常。然而，我陷入困境的是逐行工作而不是比较B＆amp; B中的整个范围。 C.我已经找到了我经常找到解决方案的地方，但我发现到目前为止我没有找到任何可行的方法，或者至少我没有任何工作可做。似乎无论我尝试什么，如果它在两列中都找到了一个部件号 - 无论该数字是在我要比较的单元格中还是在完全不同的单元格中 - 它返回一个匹配。

以下是突出显示C列差异的代码。将其修改为逐行排列将是非常好的。同时突出显示两列中的差异（目前我的每列都有一个宏）。它不仅（例如）强调B2和B2中的不匹配，甚至更加优秀。 C2，但也显示D2和D2中B2的那些不匹配值。来自E2中的C2，但这只是我的想法，不确定是否可能。有人可以帮忙解决这个问题吗？

Sub BOMMAGIC_2NDCOLUMN()
    Application.ScreenUpdating = False
    Dim rng2HL As Range, rngCheck As Range, dictWords As Object
    Dim a() As Variant, b() As Variant, wordlist As Variant, wordStart As Long
    Set r = Selection
     'Change the addresses below to match your data.
    Set rng2HL = Range("C2:C824")
    Set rngCheck = Range("B2:B824")
    a = rng2HL.Value
    b = rngCheck.Value
    Set dictWords = CreateObject("Scripting.Dictionary")
     'Load unique words from second column into a dictionary for easy checking
    For i = LBound(b, 1) To UBound(b, 1)
        wordlist = Split(b(i, 1), " ")
        For j = LBound(wordlist) To UBound(wordlist)
            If Not dictWords.Exists(wordlist(j)) Then
                dictWords.Add wordlist(j), wordlist(j)
            End If
        Next j
    Next i
     'Reset range to highlight to all black font.
    rng2HL.Font.ColorIndex = 1
     'Check words one by one against dictionary.
    For i = LBound(a, 1) To UBound(a, 1)
        wordlist = Split(a(i, 1), " ")
        For j = LBound(wordlist) To UBound(wordlist)
            If Not dictWords.Exists(wordlist(j)) Then
                wordStart = InStr(a(i, 1), wordlist(j))
                 'Change font color of word to red.
                rng2HL.Cells(i).Characters(wordStart, Len(wordlist(j))).Font.ColorIndex = 3
            End If
        Next j
    Next i
    Application.ScreenUpdating = True
End Sub

Answer 1

这是一种方法：

Sub BOMMAGIC_2NDCOLUMN_Test()

    Dim rw As Range, v1, v2, arrB, arrC, v

    For Each rw In Range("B2:C824").Rows

        rw.Font.Color = vbBlack
        rw.Offset(0, 2).Resize(1, 2).ClearContents
        v1 = Trim(rw.Cells(1).Value)
        v2 = Trim(rw.Cells(2).Value)

        If Len(v1) > 0 And Len(v2) > 0 Then
            arrB = Uniques(Split(v1, " "))
            arrC = Uniques(Split(v2, " "))

            BlankAllMatches arrB, arrC 'remove all matches

            For Each v In arrB
                If Len(v) > 0 Then
                    HighlightText rw.Cells(1), CStr(v), vbRed
                    rw.Cells(1).Offset(0, 2) = rw.Cells(1).Offset(0, 2) & " " & v
                End If
            Next v
            For Each v In arrC
                If Len(v) > 0 Then
                    HighlightText rw.Cells(2), CStr(v), vbBlue
                    rw.Cells(2).Offset(0, 2) = rw.Cells(2).Offset(0, 2) & " " & v
                End If
            Next v

        End If

    Next rw
End Sub

'Set any elements common to both arrays to ""
' Note: arrays should not contain duplicate values
Sub BlankAllMatches(ByRef a, ByRef b)
    Dim i As Long, x As Long
    For i = LBound(a) To UBound(a)
        For x = LBound(b) To UBound(b)
            If a(i) <> "" And a(i) = b(x) Then
                a(i) = ""
                b(x) = ""
            End If
       Next x
    Next i
End Sub

'EDIT: highlight all instances of "txt"
Sub HighlightText(rng As Range, txt As String, clr As Long)
    Dim wordStart, pos As Long
    pos = InStr(1, rng.Value, txt)
    Do While pos > 0
        rng.Characters(pos, Len(txt)).Font.Color = clr
        pos = InStr(pos + 1, rng.Value, txt)
    Loop
End Sub

'EDIT: added to deal with duplicates...
'return an array of unique values from input array
Function Uniques(arr)
    Dim v
    Static dict As Object
    If dict Is Nothing Then Set dict = CreateObject("scripting.dictionary")
    dict.RemoveAll
    For Each v In arr
        dict(v) = True
    Next v
    Uniques = dict.keys
End Function

程序要逐行而不是整个范围工作？

1 个答案: