比較的四個大名單超過11萬項

Question

背景：我有產品組合的四個列表中的一個項目。我們網站上的每一種產品/定製組合。這四份清單適用於我們網站的四種語言。

產品/定製組合中的每一個文字說明是在數據庫分開，多年來，已發現某些產品/定製組合一定語言從數據庫中丟失。 （即在SQL數據庫中沒有行會這樣的網站出現一個錯誤。）

問題：我每次超過11萬項數據缺失的四個列表，以簡化，假設我只有十種產品。

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項凍結。我在99％的CPU，Excel和令人驚訝的記憶仍有約1 GB免費（滿分爲4 GB）。

我試着在Stack Overflow上找到其他的解決方案，它讓我看到了一個函數，它比較了兩個變量，它們包含了整個列。這是一個For each x in arr類型的方法。這也證明了非有用的，因爲我的電腦凍結約10000項進去。

目標：在我給出的例子中，我的目標是爲每種語言提供四個較小的缺失條目列表。在這個例子中：

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

兩個主要問題，我無言以對於：

1. 如何有效地比較所有四個列表，並確保我的計算機不會崩潰？
2. 在我的例子中，如何有效地找到像7這樣的條目？

（我認爲每一個列表進行比較，以每隔名單，直到最後我比較L1與其他的一個發現7從他們大多缺少的是效率不高。）

解決方案：我選擇了下面的答案並略微修改了他的代碼。與他們在440000循環環路中

我的電腦被凍結了，我發現，通過放置的DoEvents內環路，此命令使Excel的一些呼吸空氣'。當它運行這個DoEvents時，它執行除當前正在運行的宏之外的任何備份任務，因此允許在宏運行期間編輯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. 商店中1名唯一列表
2. 存儲在數組中的每一列中的循環
3. 如同陣列唯一列表，以檢查缺少的值從所有4個列表中的值。

代碼：

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 

截圖：

比方說，你表看起來是

當您運行的代碼，輸出將在山口Ĵ起

Answer 2

如果您的計算機在掙扎一次，然後一個與所有四個列表，以應付在時間可能是有利的。你可以像@Sid建議的那樣做，創建一個包含所有可能值的一個實例的綜合列表，然後一次比較一種語言與公式，例如=IF(MATCH(A1,C:C,0)>0,"",)複製下來以適合，其中ColumnA將是您的主列表，C等每個人語言的列表。 #N/A將指示ColumnC（等）中缺少ColumnA中的哪個值。