比较四个超过110,000项目的大名单

背景：我有四个项目的产品组合列表。 我们网站上提供的每一种产品/定制组合。 这四个列表是针对我们网站的四种语言的。

产品/定制组合的每个文本描述在数据库中是分开的，并且多年以来，发现某些产品/定制组合的某些语言在数据库中缺失。 （即在SQL数据库中没有行，所以网站出现错误。）

问题：我有四个超过110,000个物品的列表，每个物品都有数据缺失，为了简化，假设我只有十个产品。

list 1 (L1): 1, 2, 3, 5, 6, 7, 8, 10 L2: 1, 2, 3, 4, 5, 6, 8, 9 L3: 1, 3, 4, 5, 6, 8, 9, 10 L4: 1, 2, 3, 4, 5, 6, 8, 9, 10 

我现在在Excel文件中有四列四列。 然而，当我现在尝试通过第一行“For”循环一直到结束（xlUp）.row …它冻结约6000条目。 我的CPU在99％，Excel和令人惊讶的内存仍然约1 GB免费（4 GB中）。

我试图在Stack Overflow上find其他的解决scheme，并且让我们看到了一个函数，它比较了两个内部有整列的变体。 这是For each x in arrtypes方法中的For each x in arr 。 这也被certificate是无用的，因为我的电脑冻结了大约一万个条目。

目标：在我给出的例子中，我的目标是为每种语言提供四个较小的缺失条目列表。 在这个例子中：

 L1: 4, 9 L2: 7 L3: 2, 7 L4: 7 

我无能为力的两个主要问题是：

1. 如何有效比较所有四个列表，并确保我的电脑不会崩溃？
2. 在我的例子中，如何有效地find像7这样的条目？

（我会假设把每个列表与其他列表进行比较，直到最后我将L1与其他列表中的一个进行比较，发现其中大部分列表中缺less7 ）效率不高。

解决scheme：我select了下面的答案，稍微修改了他的代码。

我的电脑在循环过程中冻结了超过440,000个循环，我发现通过在循环中放置一个DoEvents ，这个命令可以让Excel有一些空气来呼吸。 当它运行这个DoEvents时 ，它执行除了当前正在运行的macros之外的任何备份任务，从而允许在macros运行期间编辑Excel文件。

此外，最后，当正在写入缺失项目列表时，如果刚刚检查的列表没有遗漏，则出现错误，因此我只是使用“错误”继续进行以防万一。

 Dim MyAr As Variant Sub Sample() Dim ws As Worksheet Dim lRow As Long, n As Long, r As Long, j As Long Dim Col As New Collection Dim itm Dim aCell As Range Dim FinalList() As String '~~> Let's say this sheet has the 4 lists in Col A to D Set ws = ThisWorkbook.Sheets("Sheet2") With ws '~~> Find the last Row in Col A to D which has data If Application.WorksheetFunction.CountA(.Cells) <> 0 Then lRow = .Range("A:D").Find(What:="*", _ After:=.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row Else lRow = 1 End If '~~> Create a unique list Dim z As Variant z = 0 For Each aCell In .Range("A1:D" & lRow) If Len(Trim(aCell.Value)) <> 0 Then On Error Resume Next Col.Add aCell.Text, CStr(aCell.Text) On Error GoTo 0 End If z = z + 1 Debug.Print z DoEvents Next '~~> Output Column Say in Col J r = 10 '~~> Loop through the list to match For j = 1 To 4 Set aCell = .Range(.Cells(1, j), .Cells(lRow, j)) MyAr = aCell.Value z = 0 For Each itm In Col If ItemExist(itm) = False Then ReDim Preserve FinalList(n) FinalList(n) = itm n = n + 1 End If z = z + 1 Debug.Print z DoEvents Next '~~> Output The results .Cells(1, r).Value = "Missing List in List" & j On Error Resume Next .Cells(2, r).Resize(UBound(FinalList) + 1, 1).Value = _ Application.WorksheetFunction.Transpose(FinalList) On Error GoTo 0 r = r + 1 Erase FinalList n = 0 Next End With End Sub Function ItemExist(sVal As Variant) As Boolean Dim i As Long For i = 0 To UBound(MyAr) - 1 If sVal = MyAr(i + 1, 1) Then ItemExist = True Exit For End If Next End Function 

Answer 1

好，试试这个给我。 这不使用任何公式，因此在Excel上将很容易。 一切都在内存中执行。

逻辑：

1. 将所有4列表中的值存储在1个唯一列表中
2. 将每列存储在一个循环中的数组中
3. 将唯一列表与数组匹配以检查缺less的值。

码：

 Option Explicit Dim MyAr As Variant Sub Sample() Dim ws As Worksheet Dim lRow As Long, n As Long, r As Long, j As Long Dim Col As New Collection Dim itm Dim aCell As Range Dim FinalList() As String '~~> Let's say this sheet has the 4 lists in Col A to D Set ws = ThisWorkbook.Sheets("Sheet1") With ws '~~> Find the last Row in Col A to D which has data If Application.WorksheetFunction.CountA(.Cells) <> 0 Then lRow = .Range("A:D").Find(What:="*", _ After:=.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row Else lRow = 1 End If '~~> Create a unique list For Each aCell In .Range("A1:D" & lRow) If Len(Trim(aCell.Value)) <> 0 Then On Error Resume Next Col.Add aCell.Value, CStr(aCell.Value) On Error GoTo 0 End If Next '~~> Output Column Say in Col J r = 10 '~~> Loop through the list to match For j = 1 To 4 Set aCell = .Range(.Cells(1, j), .Cells(lRow, j)) MyAr = aCell.Value For Each itm In Col If ItemExist(itm) = False Then ReDim Preserve FinalList(n) FinalList(n) = itm n = n + 1 End If Next '~~> Output The results .Cells(1, r).Value = "Missing List in List" & j .Cells(2, r).Resize(UBound(FinalList) + 1, 1).Value = _ Application.WorksheetFunction.Transpose(FinalList) r = r + 1 Erase FinalList n = 0 Next End With End Sub Function ItemExist(sVal As Variant) As Boolean Dim i As Long For i = 0 To UBound(MyAr) - 1 If sVal = MyAr(i + 1, 1) Then ItemExist = True Exit For End If Next End Function 

截图：

比方说你列表看起来像这样

当你运行代码时，输​​出将在Col J中生成

Answer 2

如果您的计算机正在努力应付所有四个列表，那么一次一个可能是合适的。 你可以像@Sidbuild议的那样做，创build一个所有可能值的一个实例的综合列表，然后用一个公式如=IF(MATCH(A1,C:C,0)>0,"",)复制到适合，其中ColumnA将是您的主列表和C等每个单独的语言的列表。 ＃N #N/A将指示ColumnC（etc）中缺lessColumnA中的哪个值。