Vba 两列快速比较法

编辑：对于我的解决方案，请使用

 For i = 1 To tmpRngSrcMax
     If rngSrc(i) <> rngDes(i) Then ...
 Next i

因此，我使用For-Each循环通过第一列（src）进行迭代，使用CountIf方法检查第二列（des）中是否已经存在该项。如果没有，请复制到第1列（src）的末尾

代码是有效的，但在我的机器上，给定约7000行的列大约需要200秒。我注意到CountIf直接用作公式时工作得更快

---

有人对代码优化有什么想法吗？

刚刚很快写了这个。。。你能帮我测试一下吗

Sub Sample()
    Dim wsDes As Worksheet, wsSrc As Worksheet
    Dim rngDes As Range, rngSrc As Range
    Dim DesLRow As Long, SrcLRow As Long
    Dim i As Long, j As Long, n As Long
    Dim DesArray, SrcArray, TempAr() As String
    Dim boolFound As Boolean

    Set wsDes = ThisWorkbook.Sheets("Sheet1")
    Set wsSrc = ThisWorkbook.Sheets("Sheet2")

    DesLRow = wsDes.Cells(Rows.Count, 1).End(xlUp).Row
    SrcLRow = wsSrc.Cells(Rows.Count, 1).End(xlUp).Row

    Set rngDes = wsDes.Range("A2:A" & DesLRow)
    Set rngSrc = wsSrc.Range("I3:I" & SrcLRow)

    DesArray = rngDes.Value
    SrcArray = rngSrc.Value

    For i = LBound(SrcArray) To UBound(SrcArray)
        For j = LBound(DesArray) To UBound(DesArray)
            If SrcArray(i, 1) = DesArray(j, 1) Then
                boolFound = True
                Exit For
            End If
        Next j

        If boolFound = False Then
            ReDim Preserve TempAr(n)
            TempAr(n) = SrcArray(i, 1)
            n = n + 1
        Else
            boolFound = False
        End If
    Next i

    wsDes.Cells(DesLRow + 1, 1).Resize(UBound(TempAr) + 1, 1).Value = _
    Application.Transpose(TempAr)
End Sub

---

嗯。让我们澄清几件事

因此列

A

具有

10000

随机生成的值，列

I

具有

5000

随机生成的值。看起来像这样

我对10000个单元格运行了3种不同的代码

i=1到的

。。。对于j=1到…

方法，您建议的方法

Sub ForLoop()

Application.ScreenUpdating = False

    Dim stNow As Date
    stNow = Now

    Dim lastA As Long
    lastA = Range("A" & Rows.Count).End(xlUp).Row

    Dim lastB As Long
    lastB = Range("I" & Rows.Count).End(xlUp).Row

    Dim match As Boolean

    Dim i As Long, j As Long
    Dim r1 As Range, r2 As Range
    For i = 2 To lastA
        Set r1 = Range("A" & i)
        match = False
        For j = 3 To lastB
            Set r2 = Range("I" & j)
            If r1 = r2 Then
                match = True
            End If
        Next j
        If Not match Then
            Range("I" & Range("I" & Rows.Count).End(xlUp).Row + 1) = r1
        End If
    Next i

    Debug.Print DateDiff("s", stNow, Now)
Application.ScreenUpdating = True
End Sub

Sid的接近

Sub Sample()
    Dim wsDes As Worksheet, wsSrc As Worksheet
    Dim rngDes As Range, rngSrc As Range
    Dim DesLRow As Long, SrcLRow As Long
    Dim i As Long, j As Long, n As Long
    Dim DesArray, SrcArray, TempAr() As String
    Dim boolFound As Boolean

    Set wsDes = ThisWorkbook.Sheets("Sheet1")
    Set wsSrc = ThisWorkbook.Sheets("Sheet2")

    DesLRow = wsDes.Cells(Rows.Count, 1).End(xlUp).Row
    SrcLRow = wsSrc.Cells(Rows.Count, 1).End(xlUp).Row

    Set rngDes = wsDes.Range("A2:A" & DesLRow)
    Set rngSrc = wsSrc.Range("I3:I" & SrcLRow)

    DesArray = rngDes.Value
    SrcArray = rngSrc.Value

    For i = LBound(SrcArray) To UBound(SrcArray)
        For j = LBound(DesArray) To UBound(DesArray)
            If SrcArray(i, 1) = DesArray(j, 1) Then
                boolFound = True
                Exit For
            End If
        Next j

        If boolFound = False Then
            ReDim Preserve TempAr(n)
            TempAr(n) = SrcArray(i, 1)
            n = n + 1
        Else
            boolFound = False
        End If
    Next i

    wsDes.Cells(DesLRow + 1, 1).Resize(UBound(TempAr) + 1, 1).Value = _
    Application.Transpose(TempAr)
End Sub

Sub Main()
Application.ScreenUpdating = False

    Dim stNow As Date
    stNow = Now

    Dim arr As Variant
    arr = Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row).Value

    Dim varr As Variant
    varr = Range("I3:I" & Range("I" & Rows.Count).End(xlUp).Row).Value

    Dim x, y, match As Boolean
    For Each x In arr
        match = False
        For Each y In varr
            If x = y Then match = True
        Next y
        If Not match Then
            Range("I" & Range("I" & Rows.Count).End(xlUp).Row + 1) = x
        End If
    Next

    Debug.Print DateDiff("s", stNow, Now)
Application.ScreenUpdating = True
End Sub

my（mehow）方法

Sub Sample()
    Dim wsDes As Worksheet, wsSrc As Worksheet
    Dim rngDes As Range, rngSrc As Range
    Dim DesLRow As Long, SrcLRow As Long
    Dim i As Long, j As Long, n As Long
    Dim DesArray, SrcArray, TempAr() As String
    Dim boolFound As Boolean

    Set wsDes = ThisWorkbook.Sheets("Sheet1")
    Set wsSrc = ThisWorkbook.Sheets("Sheet2")

    DesLRow = wsDes.Cells(Rows.Count, 1).End(xlUp).Row
    SrcLRow = wsSrc.Cells(Rows.Count, 1).End(xlUp).Row

    Set rngDes = wsDes.Range("A2:A" & DesLRow)
    Set rngSrc = wsSrc.Range("I3:I" & SrcLRow)

    DesArray = rngDes.Value
    SrcArray = rngSrc.Value

    For i = LBound(SrcArray) To UBound(SrcArray)
        For j = LBound(DesArray) To UBound(DesArray)
            If SrcArray(i, 1) = DesArray(j, 1) Then
                boolFound = True
                Exit For
            End If
        Next j

        If boolFound = False Then
            ReDim Preserve TempAr(n)
            TempAr(n) = SrcArray(i, 1)
            n = n + 1
        Else
            boolFound = False
        End If
    Next i

    wsDes.Cells(DesLRow + 1, 1).Resize(UBound(TempAr) + 1, 1).Value = _
    Application.Transpose(TempAr)
End Sub

Sub Main()
Application.ScreenUpdating = False

    Dim stNow As Date
    stNow = Now

    Dim arr As Variant
    arr = Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row).Value

    Dim varr As Variant
    varr = Range("I3:I" & Range("I" & Rows.Count).End(xlUp).Row).Value

    Dim x, y, match As Boolean
    For Each x In arr
        match = False
        For Each y In varr
            If x = y Then match = True
        Next y
        If Not match Then
            Range("I" & Range("I" & Rows.Count).End(xlUp).Row + 1) = x
        End If
    Next

    Debug.Print DateDiff("s", stNow, Now)
Application.ScreenUpdating = True
End Sub

---

结果如下

现在，选择快速比较方法（：）

---

随机值的填充

Sub FillRandom()
    Cells.ClearContents
    Range("A1") = "Column A"
    Range("I2") = "Column I"

    Dim i As Long
    For i = 2 To 10002
        Range("A" & i) = Int((10002 - 2 + 1) * Rnd + 2)
        If i < 5000 Then
            Range("I" & Range("I" & Rows.Count).End(xlUp).Row + 1) = _ 
                 Int((10002 - 2 + 1) * Rnd + 2)
        End If
    Next i

End Sub

Sub-FillRandom（）
透明内容物
范围（“A1”）=“A列”
范围（“I2”）=“第I列”
我想我会坚持多久
对于i=2到10002
范围（“A”&i）=整数（（10002-2+1）*Rnd+2）
如果我小于5000，那么
范围（“I”和范围（“I”和Rows.Count）.End（xlUp.Row+1）=\u
整数（（10002-2+1）*Rnd+2）
如果结束
接下来我
端接头

如果您使用.Value2而不是.Value，它将再次稍微快一点。

以下是非循环代码，对于上面的示例，它几乎立即执行

Sub HTH()

    Application.ScreenUpdating = False

    With Range("A2", Cells(Rows.Count, "A").End(xlUp)).Offset(, 1)
        .Formula = "=VLOOKUP(A2,I:I,1,FALSE)"
        .Value = .Value
        .SpecialCells(xlCellTypeConstants, 16).Offset(, -1).Copy Range("I" & Rows.Count).End(xlUp).Offset(1)
        .ClearContents
    End With

    Application.ScreenUpdating = True

End Sub

您可以使用任何您喜欢的列作为伪列

信息：

关于速度测试的一些注意事项：
在运行测试之前编译vba项目。
对于每个循环，执行速度比i=1到10个循环快。
如果发现答案可以防止无意义的循环，则尽可能退出循环。
Long执行速度比integer快

最后是一种更快的循环方法（如果您必须循环，但其速度仍然不如上述非循环方法）：

根据@brettdj对下一个备选方案的评论：

For x = 1 To UBound(vData, 1)
    bMatch = False
    For y = 1 To UBound(vLookup, 1)
        If vData(x, 1) = vLookup(y, 1) Then
            bMatch = True: Exit For
        End If
    Next y
    If Not bMatch Then
        nCount = nCount + 1: vOutput(nCount, 0) = vData(x, 1)
    End If
Next x

---

我刚刚调整了如何从两个列表中获取缺少的项目。 以防有人需要它。谢谢你的代码分享

Sub Main()

Application.ScreenUpdating = False

Dim stNow As Date
stNow = Now

Dim varr As Variant
varr = Range("A2:A" & Range("A" & Rows.count).End(xlUp).row).Value

Dim arr As Variant
arr = Range("I3:I" & Range("I" & Rows.count).End(xlUp).row).Value

Dim x, y, match As Boolean
For Each y In arr
    match = False
    For Each x In varr
        If y = x Then match = True
    Next x
    If Not match Then

        Range("B" & Range("B" & Rows.count).End(xlUp).row + 1) = y

    End If
Next
Range("B1") = "Items not in A Lists"
Range("B" & Range("B" & Rows.count).End(xlUp).row + 1) = "Items not in I Lists"
'Dim arr As Variant
arr = Range("A3:A" & Range("A" & Rows.count).End(xlUp).row).Value

'Dim varr As Variant
varr = Range("I3:I" & Range("I" & Rows.count).End(xlUp).row).Value

'Dim x, y, match As Boolean
For Each x In arr
    match = False
    For Each y In varr
        If x = y Then match = True
    Next y
    If Not match Then
        Range("B" & Range("B" & Rows.count).End(xlUp).row + 1) = x
    End If
Next


Debug.Print DateDiff("s", stNow, Now)
Application.ScreenUpdating = True

End Sub

函数范围\u Iguais（rgR1作为范围，rgR2作为范围）作为布尔值
变光vRg1
变光vRg2
尺寸i为整数，j为整数
vRg1=rgR1。数值
vRg2=rgR2.值
i=0
做
i=i+1
j=0
做
j=j+1
循环直到vRg1（i，j）vRg2（i，j）或j=UBound（vRg1，2）
循环直到vRg1（i，j）vRg2（i，j）或i=UBound（vRg1，1）
范围_Iguais=（vRg1（i，j）=vRg2（i，j））
端函数

如果对数据进行了排序，则可以使用O（n）算法。这将是我的优化方法。忘记对如此庞大的数据使用工作表功能吧。将数据复制到阵列，然后进行比较。你会对它的速度感到惊喜；）

ScreenUpdate=false

在代码开头也会有一点帮助。@SiddharthRout:非常感谢，现在我们的

200s

到

不到2秒

！这就是我所说的惊喜；）使用variant数组，它的工作速度大约是原始代码的5倍。感谢这个更通用的解决方案。使用随机值平均运行约8-9秒+1对于你来说，这种方法相对较快，而且比循环和单元格的方法要好得多。你有什么可以支持你的一句话的答案吗你能试试吗？这方面有很多参考资料。。。如果你需要更多的说服力，就去搜索吧。只是想帮忙：）这是倾向于一个评论而不是一个答案——令人惊讶的是它没有被关闭-voted@whytheq问题是找到最快的代码，直到你使用Value2而不是Value2，你才会把钱留在桌子上。Value在处理日期和货币类型方面有很多开销，而Value2没有这些开销：它只是快速地处理数字。虽然它在其他地方有很好的文档记录，但这里没有提到它，但它对于快速代码非常重要。@CoolBlue-接受。。。但问题（和答案）更多地集中在所使用的算法上。您的“答案”可以作为注释添加到任何现有答案中，这将是一个很好的注释，可以提示编辑答案。如果你有两个嵌套的循环，并且你的算法是在二次时间内运行的，谁在乎你是使用value还是value2呢？答案是将算法移动到对数时间还是线性时间……通过一些微调，比如你的评论。把你的答案和我的比较…很好的分析。你试过@Reafidy的第一个建议吗？很高兴添加到速度比较中—避免所有嵌套循环（请注意，目前正在修改您的方法并将有用的代码添加到我的文件中……这提醒了我—什么是“社区Wiki”？）@是的，我确实尝试过，因为他的方法也非常快。+1我喜欢使用未充分利用的公式插入。注意，@brettdj，谢谢你的文章，你是非常正确的。然而，在本例中，每种方法都明显更快你们能不能做一个不同的颜色代码的匹配，发现红色？你能解释一下你的答案吗？

Function Ranges_Iguais(rgR1 As Range, rgR2 As Range) As Boolean

  Dim vRg1 As Variant
  Dim vRg2 As Variant
  Dim i As Integer, j As Integer

  vRg1 = rgR1.Value
  vRg2 = rgR2.Value
  i = 0

  Do
    i = i + 1
    j = 0
    Do
        j = j + 1
    Loop Until vRg1(i, j) <> vRg2(i, j) Or j = UBound(vRg1, 2)
  Loop Until vRg1(i, j) <> vRg2(i, j) Or i = UBound(vRg1, 1)

  Ranges_Iguais = (vRg1(i, j) = vRg2(i, j))

End Function

    Set R1 = Range(S1.Cells(1, 1), S1.Cells.SpecialCells(xlCellTypeLastCell))
    Set R2 = Range(S2.Cells(1, 1), S2.Cells.SpecialCells(xlCellTypeLastCell))
    If R1.Count = R2.Count Then
        Set R3 = Range(S3.Cells(1, 1), S3.Cells(S2.Cells.SpecialCells(xlCellTypeLastCell).Row, S2.Cells.SpecialCells(xlCellTypeLastCell).Column))
        R3.Formula = "=" & R1.Address(, , , True) & "=" & R2.Address(, , , True)
        Set R = R3.Find(What:="FALSE", After:=S3.Cells(1, 1), LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=True, SearchFormat:=False)
        bComp = R Is Nothing
    Else
        bComp = False
    End If