比較快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

你能解釋一下你的答案嗎？ –

回答

相關問題