Question

我试图修改比较两列的VBA代码。

我在exceltip.com找到了它：

Sub PullUniques()
    Dim rngCell As Range
    For Each rngCell In Range("A2:A40")
        If WorksheetFunction.CountIf(Range("B2:B40"), rngCell) = 0 Then
            Range("C" & Rows.Count).End(xlUp).Offset(1) = rngCell
        End If
    Next
    For Each rngCell In Range("B2:B40")
        If WorksheetFunction.CountIf(Range("A2:A40"), rngCell) = 0 Then
            Range("D" & Rows.Count).End(xlUp).Offset(1) = rngCell
        End If
    Next
End Sub

由于它处理了40行，我试图编辑成这样的东西：

Sub PullUniques()
    Dim rngCell As Range
    For Each rngCell In Range("A2").End(xlDown)
        If WorksheetFunction.CountIf(Range("B2").End(xlDown), rngCell) = 0 Then
            Range("C" & Rows.Count).End(xlUp).Offset(1) = rngCell
        End If
    Next
    For Each rngCell In Range("B2").End(xlDown)
        If WorksheetFunction.CountIf(Range("A2").End(xlDown), rngCell) = 0 Then
            Range("D" & Rows.Count).End(xlUp).Offset(1) = rngCell
        End If
    Next
End Sub

它只给了我一行与列不匹配的行。可能我用了＃34; End（xlDown）＆＃34;以错误的方式。

我创建了这样的东西，但速度很慢（我将比较的文件不会超过100k行）：

Sub PullUniques()
    Dim rngCell As Range
    For Each rngCell In Range("A2:A99999")
        If WorksheetFunction.CountIf(Range("B2:B99999"), rngCell) = 0 Then
            Range("C" & Rows.Count).End(xlUp).Offset(1) = rngCell
        End If
    Next
    For Each rngCell In Range("B2:B99999")
        If WorksheetFunction.CountIf(Range("A2:A99999"), rngCell) = 0 Then
            Range("D" & Rows.Count).End(xlUp).Offset(1) = rngCell
        End If
    Next
End Sub

有没有办法优化它？为什么End（xlDown）会失败？

Answer 1

按如下方式调整代码：

Sub PullUniques()
    Dim rngCell As Range
    For Each rngCell In Range(Range("A2"),Range("A2").End(xlDown))
        If WorksheetFunction.CountIf(Range(Range("B2"),Range("B2").End(xlDown)), rngCell) = 0 Then
            Range("C" & Rows.Count).End(xlUp).Offset(1) = rngCell
        End If
    Next
    For Each rngCell In Range(Range("B2"),Range("B2").End(xlDown))
        If WorksheetFunction.CountIf(Range(Range("A2"),Range("A2").End(xlDown)), rngCell) = 0 Then
            Range("D" & Rows.Count).End(xlUp).Offset(1) = rngCell
        End If
    Next
End Sub

.End(xlDown)仅指一个单元格。

Answer 2

这更像是一项练习，看看我是否能够提高效率

以下是测试结果

Compare2Cols() - Rows:    10,001; Time:   0.047 sec;     PullUniquesFixed() -   4.277 sec
Compare2Cols() - Rows:    20,001; Time:   0.109 sec;     PullUniquesFixed() -  15.975 sec
Compare2Cols() - Rows:    30,001; Time:   0.156 sec;     PullUniquesFixed() -  31.982 sec
Compare2Cols() - Rows:    40,001; Time:   0.234 sec;     PullUniquesFixed() -  64.472 sec
Compare2Cols() - Rows:    50,001; Time:   0.296 sec;     PullUniquesFixed() - 104.645 sec
Compare2Cols() - Rows:   100,001; Time:   1.232 sec;     PullUniquesFixed() -     N/A
Compare2Cols() - Rows:   500,001; Time:  31.934 sec;     PullUniquesFixed() -     N/A
Compare2Cols() - Rows: 1,048,576; Time: 126.797 sec;     PullUniquesFixed() -     N/A

<强> PullUniquesFixed（）

Option Explicit

Public Sub PullUniquesFixed()
    Dim ws As Worksheet:    Set ws = ThisWorkbook.ActiveSheet
    Dim rngCell As Range, t As Double, tr As String
    t = Timer

    Application.ScreenUpdating = False
    With ws.UsedRange
        For Each rngCell In .Columns(1).Offset(1).Cells
            If WorksheetFunction.CountIf(.Columns(2), rngCell) = 0 Then
                Range("C" & Rows.Count).End(xlUp).Offset(1) = rngCell
            End If
        Next
        For Each rngCell In .Columns(2).Offset(1).Cells
            If WorksheetFunction.CountIf(.Columns(1), rngCell) = 0 Then
                Range("D" & Rows.Count).End(xlUp).Offset(1) = rngCell
            End If
        Next
    End With
    Application.ScreenUpdating = True

    tr = "PullUniques()        - Rows: " & Format(ws.UsedRange.Rows.Count, "#,###") & "; "
    Debug.Print tr & "Time: " & Format(Timer - t, "0.000") & " sec"
End Sub

与End(xlDown)相关的注释 - 如果您的列中有空单元格，它可能无法正常工作。例如，在我的B列测试图像中，Range("B2").End(xlDown)将返回第4行（与单击B2并按向下箭头相同），因此它将忽略所有单元格，因此有时如果使用它可能会更好Range("B" & Rows.Count).End(xlUp) - 与选择列中的最后一个单元格（1M行+）并按向上箭头

相同

Compare2Cols（） - 它使用2个词典和4个数组以获得更好的性能

Option Explicit

Public Sub Compare2Cols()
    Dim dColA As Object:    Set dColA = CreateObject("Scripting.Dictionary")
    Dim dColB As Object:    Set dColB = CreateObject("Scripting.Dictionary")

    Dim ur As Range:        Set ur = ActiveSheet.UsedRange

    ur.Columns("C:D").Delete
    Dim arrA As Variant:    arrA = ur.Columns("A")
    Dim arrB As Variant:    arrB = ur.Columns("B")
    Dim arrC As Variant:    arrC = ur.Columns("C")
    Dim arrD As Variant:    arrD = ur.Columns("D")

    Dim itm As Variant, r As Long
    For Each itm In arrA
        dColA(itm) = 0
    Next
    For Each itm In arrB
        dColB(itm) = 0
    Next

    For Each itm In dColA
        r = r + 1
        If Not dColB.Exists(itm) Then arrC(r, 1) = itm   'Find Col 1 in 2
    Next
    r = 0
    For Each itm In dColB
        r = r + 1
        If Not dColA.Exists(itm) Then arrD(r, 1) = itm   'Find Col 2 in 1
    Next

    ur.Columns("C") = arrC
    ur.Columns("D") = arrD
End Sub

测试数据

stackoverflow answer explaining it here

确定包含数据的最后一行以比较两列

2 个答案: