Question

我正在运行VBA来搜索D列和G列之间行中值的差异。我的代码适用于第一次尝试，但是当我向末尾添加更多值（不是相同的值）时，代码似乎没有。

Option Explicit

Public Sub RateTest1()
Const COLUMN_1 = "D", WS1_START = 2
Const COLUMN_2 = "G", WS2_START = 2
Dim ws1 As Worksheet, ws2 As Worksheet, col1 As Variant, col2 As Variant,     tr As Long
Dim max1 As Long, max2 As Long, r1 As Long, r2 As Long, red As Long, found As Boolean
Dim miss As Range

tr = Rows.Count:                         red = RGB(255, 0, 0)
Set ws1 = ThisWorkbook.Sheets("Sheet1"): max1 = ws1.Cells(tr, COLUMN_1).End(xlUp).Row
Set ws2 = ThisWorkbook.Sheets("Sheet1"): max2 = ws2.Cells(tr, COLUMN_2).End(xlUp).Row

col1 = ws1.Range(ws1.Cells(1, COLUMN_1), ws1.Cells(max1, COLUMN_1))
col2 = ws2.Range(ws2.Cells(1, COLUMN_2), ws2.Cells(max2, COLUMN_2))

For r2 = WS2_START To max2
    For r1 = WS1_START To max1
        If Len(col1(r1, 1)) > 0 And col1(r1, 1) <> "N/A" Then
            found = (col1(r1, 1) = col2(r2, 1))
            If found Then Exit For
        End If
    Next
    If Not found Then
        If miss Is Nothing Then
            Set miss = ws2.Cells(r2, COLUMN_2)
        Else
            Set miss = Union(miss, ws2.Cells(r2, COLUMN_2))
        End If
    End If
Next
miss.Interior.Color = red


For r2 = WS2_START To max2
    For r1 = WS1_START To max1
        If Len(col2(r2, 1)) > 0 And col1(r2, 1) <> "N/A" Then
            found = (col1(r2, 1) = col2(r1, 1))
            If found Then Exit For
        End If
    Next
    If Not found Then
        If miss Is Nothing Then
            Set miss = ws2.Cells(r2, COLUMN_2)
        Else
            Set miss = Union(miss, ws2.Cells(r2, COLUMN_2))
        End If
    End If
Next
miss.Interior.Color = red

End Sub

如果D中的值大于G并且几乎没有反过来，则代码有时仅识别出列D和G是不同的。＆＃34; N / A＆＃34;代码就在那里因为最终我想添加不突出显示的代码，如果列D有1并且列G有＆＃34; N / A＆＃34;。这些被认为是相同的价值观。

Answer 1

两个程序将找到两列之间的差异（非空值），但D列中值“1”除外，G列中值“N / A”

Option Explicit

Public Sub RateTest()
    Dim ws As Worksheet, miss As Range, tmp As Range, t As Double
    Dim max1 As Long, max2 As Long, colD As Range, colG As Range

    t = Timer
    Set ws = ThisWorkbook.Sheets("Sheet1")

    max1 = ws.Cells(Rows.Count, "D").End(xlUp).Row
    max2 = ws.Cells(Rows.Count, "G").End(xlUp).Row
    Set colD = ws.Range(ws.Cells(2, "D"), ws.Cells(max1, "D"))
    Set colG = ws.Range(ws.Cells(2, "G"), ws.Cells(max2, "G"))
    colD.Interior.ColorIndex = xlColorIndexNone
    colG.Interior.ColorIndex = xlColorIndexNone

    Set miss = CheckColumns(colD, colG, "N/A")

    If miss Is Nothing Then
        Set miss = CheckColumns(colG, colD, "1")
    Else
        Set tmp = CheckColumns(colG, colD, "1")
        If Not tmp Is Nothing Then Set miss = Union(miss, tmp)
    End If

    If Not miss Is Nothing Then miss.Interior.Color = RGB(255, 0, 0)
    Debug.Print "Rows: " & max1 & "; Time: " & Format(Timer - t, "0.000") & " sec"
End Sub

Private Function CheckColumns(col1 As Range, col2 As Range, x As String) As Range

    Dim c As Variant, r As Long, d As Object, rng As Range

    col1.NumberFormat = "#,##0.00###"
    c = col1.Value2
    Set d = CreateObject("Scripting.dictionary")
    For r = 1 To UBound(c)
        With col1.Cells(r)
            If .Errors.Item(xlNumberAsText).Value Then .Value2 = .Value2 + 0
        End With
        d(Trim$(CStr(c(r, 1)))) = vbNullString
    Next

    c = col2.Value2
    For r = 1 To UBound(c)
        If Len(c(r, 1)) > 0 Then
            If c(r, 1) <> x Then
                If Not d.exists(Trim(CStr(c(r, 1)))) Then
                    If rng Is Nothing Then
                        Set rng = col2.Cells(r)
                    Else
                        Set rng = Union(rng, col2.Cells(r))
                    End If
                End If
            End If
        End If
    Next
    Set CheckColumns = rng
End Function

修改以包含测试结果：

数字格式：

MS对Cells().Errors的引用

VBA-搜索重复项时未识别列中的新值

1 个答案: