2列快速比较法
编辑：而不是我的解决scheme，使用类似的东西
For i = 1 To tmpRngSrcMax If rngSrc(i) <> rngDes(i) Then ... Next i 它快了100倍。
我必须使用VBA比较包含string数据的两列。 这是我的做法：
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循环遍历第一个（src）列，并使用CountIf方法检查该项是否已经存在于第二个（des）列中。 如果不是，则复制到1st（src）列的末尾。
代码工作，但在我的机器上，大约需要7000行左右列约200s。 我注意到，当直接用作公式时，CountIf的工作方式更快。
有没有人有代码优化的想法？
好。 让我们澄清一些事情。
所以A列有10,000随机生成的值，列I有5000随机生成的值。 看起来像这样
我已经针对10,000个单元运行了3个不同的代码。
for i = 1 to ... for j = 1 to ...方法，你build议的那个
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
我的（多less）方法
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
结果如下
现在，你select快速比较方法 🙂
填入随机值
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
这里是非循环的代码，几乎立即执行上面给出的例子从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
你可以使用任何你喜欢的列作为虚拟列。
信息： 完成陷入循环
关于速度testing的一些说明：
在运行testing之前编译vba项目。
对于每个循环执行比对于I = 1到10循环更快。
如果可能的话退出循环，如果find答案来防止无意义的循环与Exit For。
Long比整数执行速度快。
最后一个更快的循环方法（如果你必须循环，但仍然不如上述非循环方法那么快）：
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 Next的替代scheme：
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
如果你使用.Value2而不是.Value，它会再快一点。
只是写了这个很快…你能testing这个给我吗？
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 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
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