比较快2列

编辑的方法：而不是为我的解决方案，使用类似比较快2列

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

这大约要快100倍。

我必须使用VBA比较包含字符串数据的两列。这是我的方法：

Set rngDes = wsDes.Range("A2:A" & wsDes.Cells(Rows.Count, 1).End(xlUp).Row) 
Set rngSrc = wsSrc.Range("I3:I" & wsSrc.Cells(Rows.Count, 1).End(xlUp).Row) 

tmpRngSrcMax = wsSrc.Cells(Rows.Count, 1).End(xlUp).Row 
cntNewItems = 0 

For Each x In rngSrc 

tmpFound = Application.WorksheetFunction.CountIf(rngDes, x.Row) 
Application.StatusBar = "Processed: " & x.Row & " of " & tmpRngSrcMax & "/" & Format(x.Row/tmpRngSrcMax, "Percent") 
DoEvents ' keeps Excel away from the "Not responding" state 

If tmpFound = 0 Then ' new item 
    cntNewItems = cntNewItems + 1 

    tmpLastRow = wsDes.Cells(Rows.Count, 1).End(xlUp).Row + 1 ' first empty row on target sheet 
    wsDes.Cells(tmpLastRow, 1) = wsSrc.Cells(x.Row, 9) 
End If 
Next x

所以，我用一个For Each循环来遍历槽1日（SRC）柱，和COUNTIF方法来检查，如果该项目是在第二个已经存在（DES）柱。如果不是，则复制到第一个（src）列的末尾。

该代码可以工作，但在我的机器上，大约需要7000行的列需要200秒。我注意到当直接用作公式时，CountIf的工作方式更快。

有没有人有代码优化的想法？

来源

2013-10-24 Clemens

你可以使用一个O（n）的算法，如果对数据进行排序。这将是我的优化方法。 – Bathsheba

忘记使用Worksheetfucntion来处理如此庞大的数据。将数据复制到数组，然后进行比较。你会惊喜于速度;） –

'ScreenUpdating = false'在你的代码开始处也会有所帮助。 –

好的。让我们澄清一些事情。

所以第A列有10,000随机生成的值，第I列有5000个随机生成的值。它看起来像这样

enter image description here

我已经对10000个细胞上运行3个不同的代码。

的for i = 1 to ... for j = 1 to ...方法，你的建议的一个

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的appraoch

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

我（mehow）方法

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

个

结果如下

enter image description here

现在

，选择在随机值的快速比较方法 :)

填充

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

来源

2013-10-24 15:42:51

好的分析。你有没有尝试类似@Reafidy提出的第一个建议？很高兴加入到你的速度比较 - 避免嵌套循环所有在一起（PS目前刻痕你的方法，并添加到我的有用代码文件....这提醒我 - 什么是“社区维基”？） – whytheq

@whytheq是我确实尝试了，并且以很快的速度提高了他的方法。 – 2014-01-30 14:45:44

只是写了这个很快......你能测试这个给我吗？

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

来源

2013-10-24 13:57:59

使用变体数组，它的工作速度比原始代码快5倍。感谢这个更一般的解决方案。 – Clemens

平均约8-9秒以随机值运行。 +1给你的方法，相对FAST而言，要比'for'循环和单元格处理方式好得多 – 2013-10-24 15:44:31

如果哟你用.Value2而不是.Value它会再快一点。

来源

2013-10-24 16:17:05

你有*任何*支持你的一句话的答案？：P – 2013-10-25 07:00:54

你试过了吗？有很多这方面的参考......只是搜索，如果你需要更多的说服力。只是试图帮助:) –

这是倾向于一个评论，而不是一个答案 - 惊讶它并没有被降低投票 – whytheq

这里是非循环代码，几乎立即执行上面给出的例子从mehow。

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

您可以使用任何您喜欢的列作为虚拟列。

信息： Done get caught in the loop

速度测试的一些注意事项：
运行测试之前，编译VBA项目。
对于每个循环执行速度比对于i = 1到10循环更快。
如果可以退出循环，如果发现答案可以防止无意义的循环与Exit For。
长度比整数执行速度快。

最后一个更快的循环方法（如果你必须循环，但它仍然没有快如上述非循环法）：

Sub Looping() 
    Dim vLookup As Variant, vData As Variant, vOutput As Variant 
    Dim x, y 
    Dim nCount As Long 
    Dim bMatch As Boolean 

    Application.ScreenUpdating = False 

    vData = Range("A2", Cells(Rows.Count, "A").End(xlUp)).Value 
    vLookup = Range("I2", Cells(Rows.Count, "I").End(xlUp)).Value 

    ReDim vOutput(UBound(vData, 1), 0) 

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

    Range("I" & Rows.Count).End(xlUp).Offset(1).Resize(nCount).Value = vOutput 

    Application.ScreenUpdating = True  

End Sub

按照@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

来源

2013-11-07 20:26:04 Reafidy

+1很快确实 – 2013-11-09 11:01:53

+1我喜欢使用如果使用不足的公式插入。 – brettdj

虽然注意[对于每个循环阵列不建议]（http://support.microsoft.com/kb/129931） – brettdj

我只是调整了Mehow从两个列表中获取物品。以防万一有人需要它。感谢您的代码共享

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

来源

2014-03-19 16:10:33 crazynut

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

来源

2014-08-11 21:42:37 Gera

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

来源

2015-12-14 09:10:43

你能解释一下你的答案吗？ –

回答

相关问题