我需要大量的Excel工作表（行7500和16000）。我需要查看列表1中的哪些项目不在列表2中...以及列表2中哪些项目不在列表1中，然后将这些结果粘贴到第三个表单上。
我决定将两个列表存储在两个集合中。到目前为止效果很好。当我尝试遍历集合时，找到与我的计算机冻结的内容，因为文件太大。
如何更改代码以便更快？我觉得必须有一个更好的方法来做这个，而不是循环遍历列表2中的每个i和列表2中的每个z。
谢谢！
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
答案 0 :(得分：3)
Activate Dim V As Variant
With Worksheets("FundserveFL")
V = .Range("L1", .Cells(.Rows.Count, "L").End(xlUp)).Resize(columnsize:=6)
End With
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
如果您类似地处理第二个工作表上的数据，创建一个数组，在创建一个键后将其添加到同一个集合中，这将导致＆＃34;错误＆＃34;如果你试图添加一个副本，你将得到一个不包含重复项的集合。使用该集合填充数组，并将其写入第三个工作表。
我猜想使用上述技术可以将你的速度提高至少10倍，如果不是更多的话。
修改
如果你想做一个独特的清单以外的事情，那只是理解逻辑的问题。例如，如果在评论中有两个数组1,2,3,4和1,3,4,5，则可以执行以下操作。当然，要理解一个假设是在任一阵列中都没有重复:(如果有，也可以处理，只需要不同的逻辑）
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
答案 1 :(得分：2)
我有一个类似大小的东西列表，我经常需要创建一个唯一的值列表。我不确定你为什么要同时使用两个系列。将数据从一个工作表加载到集合中，然后循环浏览另一个工作表以查看它是否已存在于集合中要简单得多。这是我的一些代码可以帮助你写你的。
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
答案 2 :(得分：1)
您从范围开始，然后以它们结束。如何跳过收藏品？
请试试这个：
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中最快的函数之一。
在构建第二个数组时，我们已经可以检查第一个数组并将uniques直接推送到输出数组。
调整第二个数组的大小（使用保留）允许我们将其与Match一起使用。
最后检查第一个数组与第二个数组的对象，并将它们也推送到输出数组中。
现在我们可以直接将值复制到目的地（一步）
注意：
- 您可以先删除“输出范围”（稍后的较小列表不会覆盖oler值。）
- 我无法进行真正的检查（你可能需要通过我错过的评论来报告错误）
- 此代码不检查一个列表中的双打（在列表1中有1个项目2次但在列表2中没有，在结束时将打印2次/如果您需要此检查，则只需撰写注释）
答案 3 :(得分：0)
感谢您的帮助！这是我的答案。它主要来自Ron的答案 - 我当然添加了一些调整。
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