VBA集合增加速度：匹配两个列表，find什么不匹配
我必须大量的Excel表（行7500和16000）。 我需要查看列表1中的项目不在列表2中，列表2中不包含列表1中的项目，然后将这些结果粘贴到第三个表格中。
我决定将这两个列表存储在两个集合中。 到目前为止效果很好。 当我试图循环访问集合来查找与计算机不匹配的内容时，由于文件太大而冻结。
我怎样才能改变我的代码，使其更快？ 我觉得有必要有一个更好的方法来做到这一点，而不是循环遍历列表一和列表二中的每一个我。
谢谢！
Sub FullListCompareFSvDF() Worksheets("FundserveFL").Activate 'Open New Collection and define every variable Dim FSTrades As New Collection Dim c As Long Dim i As Long Dim z As Long Dim searchFor As String 'enter the items into the list. There are blank rows and so the first IF Statement is to ignore these. ' The Else Statement shows an account number as the item and an account number & balance (FS.Offset(0,6).Value) as the key Dim FS As Range For Each FS In Sheet1.Range("L:L") If FS = "" Then Else: FSTrades.Add CStr(FS.Value & " " & FS.Offset(0, 6).Value) End If Next Worksheets("DatafileFL").Activate Dim DFTrades As New Collection 'enter the items into the list. There are blank rows as well as random numbers and so the first IF Statement is to ignore these (all account numbers are greater than 10000 '"Matching" is displayed for all errors - during an error read the account number from two columns over. ' The Else Statement shows an account number as the item and an account number & balance (FS.Offset(0,6).Value) as the key Dim DF As Range For Each DF In Sheet2.Range("H:H") If DF = "" Or Not IsNumeric(DF.Offset(0, 2)) Or DF < 10000 Then ElseIf DF.Offset(0, -4) = "MATCHING" Then DFTrades.Add CStr(DF.Offset(0, 2).Value & " " & DF.Value) Else: DFTrades.Add CStr(DF.Value & " " & DF.Offset(0, -2).Value) End If Next 'loop through the first collection. Find the first item and try to match it with the items in the second collection. 'Collection 1 Item 1... is it in Collection 2 Item 1? No - then is it in Collection 2 Item 2? When a match is found, move on to Collection 1 Item 2... If no match is found send the item to "ForInvestigation" worksheet For i = 1 To FSTrades.Count searchFor = FSTrades(i) z = 0 Do z = z + 1 If z > DFTrades.Count Then c = c + 1 Worksheets("ForInvestigation").Activate Cells(c, 1).Value = DFTrades(i) Exit Do Else: If DFTrades(z) = searchFor Then Exit Do End If End If Loop Next 'Clear Collections Set FSTrades = Nothing Set DFTrades = Nothing End Sub - 不要
Activate - 在一个步骤中将所有相关的单元格读入一个variables数组。 例如：
Dim V As Variant With Worksheets("FundserveFL") V = .Range("L1", .Cells(.Rows.Count, "L").End(xlUp)).Resize(columnsize:=6) End With
- 为您的collections创build一个可以用来查看是否有重复的键。
On Error Resume Next For i = 1 To UBound(V, 1) If V(i, 1) <> "" Then FSTrades.Add Item:=CStr(V(i, 1) & " " & V(i, 6)), Key:=CStr(V(i, 1) & " " & V(i, 6)) End If Next i On Error Resume Next
如果你类似地处理你的第二个工作表上的数据，创build一个数组，如果你尝试添加一个副本，在创build一个会“错误”的关键字后将它添加到同一个集合中，你将会得到一个不包含重复项的集合。 使用该集合填充数组，然后将其写入第三个工作表。
我猜测使用上述技术会使速度提高至less十倍，甚至更多。
编辑：
如果你想做的不是一个独特的列表，而只是理解逻辑的问题。 例如，如果在你的注释中，你有两个数组1,2,3,4和1,3,4,5，你可以做如下的事情。 当然，理解一个假设就是两个arrays中都没有重复：（如果存在，那么也可以处理，只需要一个不同的逻辑）
Sub foo() Dim V1, V2 Dim COL As Collection Dim I As Long V1 = Array(1, 2, 3, 4) V2 = Array(1, 3, 4, 5) Set COL = New Collection For I = 0 To UBound(V1) COL.Add V1(I), CStr(V1(I)) Next I On Error Resume Next For I = 0 To UBound(V2) COL.Add V2(I), CStr(V2(I)) Select Case Err.Number Case 457 'This is a duplicate, so will remove Err.Clear COL.Remove CStr(V2(I)) Case Is <> 0 MsgBox "Error No. " & Err.Number & vbTab & Err.Description End Select Next I Stop End Sub
例程停止时，如果检查COL ，将会看到它只包含2和5
我有一个类似大小的列表，我经常需要创build一个唯一的值列表。 我不知道为什么你要一次处理两个集合。 将一张纸上的数据加载到集合中然后循环通过另一张纸来查看它是否已经存在于集合中是非常简单的。 这是我的一些代码来帮助你写你的。
Dim colUniqueSNs As New Collection On Error Resume Next For r = 2 To Sheets("Inventory").UsedRange.Rows.Count strSN = Sheets("Inventory").Cells(r, 6).Text strHost = Sheets("Inventory").Cells(r, 2).Text If Not InCollection(colUniqueSNs, strSN) Then colUniqueSNs.Add strHost, strSN Next On Error GoTo 0 Public Function InCollection(col As Collection, key As Variant) As Boolean Dim obj As Variant On Error GoTo err InCollection = True obj = col(key) Exit Function err: InCollection = False End Function
你从范围开始，并且以他们结束。 如何跳过collections品呢？
请试试这个：
Sub FullListCompareFSvDF() Dim Ran1Val As Variant, Ran1ValOffset As Variant, Ran2Val As Variant Ran1Val = Intersect(Sheet1.Columns(12), Sheet1.UsedRange).Value Ran2Val = Intersect(Sheet1.Columns(18), Sheet1.UsedRange).Value Dim i As Long, j As Long For i = 1 To UBound(ranval1) If Len(Ran1Val(i, 1)) Then Ran1Val(i, 1) = Ran1Val(i, 1) & " " & Ran2Val(i, 1) Next Ran2Val = Intersect(Sheet2.Range("D:J"), Sheet2.UsedRange).Value Dim OutputVal() As Variant ReDim OutputVal(1 To UBound(Ran1Val) + UBound(Ran2Val), 1 To 1) For i = 1 To UBound(Ran2Val) If Ran2Val(i, 5) <> "" And IsNumeric(Ran2Val(i, 7)) And Ran2Val(i, 5) > 10000 Then If Ran2Val(i, 1) = "MATCHING" Then Ran2Val(i, 1) = CStr(Ran2Val(i, 7) & " " & Ran2Val(i, 5)) Else Ran2Val(i, 1) = CStr(Ran2Val(i, 5) & " " & Ran2Val(i, 3)) End If If IsNumeric(Application.Match(Ran2Val(i, 1), Ran1Val, 0)) Then j = j + 1 OutputVal(j, 1) = Ran2Val(i, 1) End If Else Ran2Val(i, 1) = "" End If Next ReDim Preserve Ran2Val(1 To UBound(Ran2Val), 1 To 1) Dim runNer As Variant For Each runNer In Ran1Val If Len(runNer) Then If IsNumeric(Application.Match(runNer, Ran2Val, 0)) Then j = j + 1 OutputVal(j, 1) = runNer End If End If Next If j > 0 Then Worksheets("ForInvestigation").Range("A1:A" & j).Value = OutputVal End If End Sub
我只是获取数组中的Range.Value 。 删除所有未使用的值，并有一个维（1到1）允许我们使用Application.Match这是Excel中最快的function之一。
在build立第二个数组的时候，我们已经可以检查第一个数组了，直接将unique直接推送到输出数组。
调整第二个数组（保留）允许我们也使用这个Match 。
最后检查第一个数组与第二个数组的对应关系，并将它们也推送到我们的输出数组中。
现在我们可以直接将值复制到您的目的地（一步）
注意：
– 您可以先删除“输出范围”（稍后的小表不会覆盖oler值）。
– 我无法执行真正的检查（您可能需要通过我错过的评论来报告错误）
– 这个代码不会在一个列表中检查双打（在列表1中有1个项目2次，但不在列表2中，将在最后打印2次/如果你需要这个检查，那么只写一个评论）
感谢您所有的帮助！ 这是我的答案。 这主要来自罗恩的回答 – 我当然增加了一些调整。
Sub MatchFSTradesDFTrades2() Dim V1 As Variant Dim V2 As Variant Dim COL As New Collection Dim I As Long Worksheets("DatafileFL").Activate With Worksheets("FundserveFL") V1 = .Range("L1", .Cells(.Rows.Count, "L").End(xlUp)).Resize(columnsize:=7) End With With Worksheets("DatafileFL") V2 = .Range("F1", .Cells(.Rows.Count, "D").End(xlUp)).Resize(columnsize:=12) End With For I = 1 To UBound(V1) If V1(I, 1) = " " Or Not IsNumeric(V1(I, 1)) Or V1(I, 1) < 10000 Or V1(I, 1) = "***" Or Not IsNumeric(V1(I, 3)) Or (V1(I, 5)) = "Buy-EC" Or (V1(I, 5)) = "Sell-EC" Then Else: COL.Add (V1(I, 1)) & " " & (V1(I, 7)), CStr(V1(I, 1)) & " " & (V1(I, 7)) End If Next I For I = 1 To COL.Count Sheet3.Cells(I + 1, 1).Value = COL.Item(I) Next On Error Resume Next For I = 1 To UBound(V2) If V2(I, 1) = "MATCHING" Then If IsNumeric(V2(I, 5)) Then COL.Add (V2(I, 7)) & " " & V2(I, 5), CStr(V2(I, 7)) & " " & V2(I, 5) Select Case Err.Number Case 457 'This is a duplicate, so will remove Err.Clear COL.Remove CStr(V2(I, 7)) & " " & V2(I, 5) End Select Else: V2(I, 12) = Right(V2(I, 5), Len(V2(I, 5)) - 1) V2(I, 12) = Format(V2(I, 12), "General Number") COL.Add (V2(I, 7)) & " " & V2(I, 12), CStr(V2(I, 7)) & " " & V2(I, 12) Select Case Err.Number Case 457 'This is a duplicate, so will remove Err.Clear COL.Remove CStr(V2(I, 7)) & " " & V2(I, 12) End Select End If ElseIf V2(I, 5) = " " Or Not IsNumeric(V2(I, 5)) Or V2(I, 5) < 10000 Or V2(I, 5) = "***" Or V2(I, 1) = "BULK" Then Else: If IsNumeric(V2(I, 3)) Then COL.Add (V2(I, 5)) & " " & V2(I, 3), CStr(V2(I, 5)) & " " & V2(I, 3) Select Case Err.Number Case 457 'This is a duplicate, so will remove Err.Clear COL.Remove CStr(V2(I, 5)) & " " & V2(I, 3) End Select Else: V2(I, 12) = Right(V2(I, 3), Len(V2(I, 3)) - 1) V2(I, 12) = Format(V2(I, 12), "General Number") COL.Add (V2(I, 5)) & " " & V2(I, 12), CStr(V2(I, 5)) & " " & V2(I, 12) Select Case Err.Number Case 457 'This is a duplicate, so will remove Err.Clear COL.Remove CStr(V2(I, 5)) & " " & V2(I, 12) End Select End If End If Next Worksheets("ForInvestigation").Activate Cells.Clear For I = 1 To COL.Count Sheet3.Cells(I + 1, 1).Value = COL.Item(I) Next Range("A:A").Select Selection.TextToColumns DataType:=xlDelimited, Space:=True, Other:=True Range("A1") = "Trade ID Number" Range("A1").Font.Bold = True Range("B1") = "Net Balanace On Trade" Range("B1").Font.Bold = True End Sub