编辑:而不是我的解决方案,请使用类似
的内容 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方法检查该项是否已存在于2nd(des)列中。如果没有,请复制到第1(src)列的末尾。
代码有效,但在我的机器上,给定大约7000行的列需要大约200秒。我注意到,当直接用作公式时,CountIf的工作速度更快。
有没有人有代码优化的想法?
答案 0 :(得分:9)
确定。让我们澄清一些事情。
因此,列A
具有10,000
个随机生成的值,列I
具有5000
个随机生成的值。看起来像这样
我针对10,000个单元格运行了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
结果如下
现在,您选择快速比较方法:)
填写随机值
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
答案 1 :(得分:5)
这是非循环代码,几乎可以立即执行上面给出的示例。
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的无意义循环
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替代方案:
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
答案 2 :(得分:2)
如果使用.Value2而不是.Value,它会再次快一点。
答案 3 :(得分:1)
快速写下来......你能为我测试一下吗?
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
答案 4 :(得分:1)
我只是调整了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
答案 5 :(得分:0)
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
答案 6 :(得分:0)
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