database - 比较超过 110,000 项的四个大型列表

Question

背景:我有一个项目的四个产品组合列表。我们网站上提供的每一种产品/定制组合中的每一种。这四个列表适用于我们网站的四种语言。

产品/定制组合的每个文本描述在数据库中都是单独的，多年来，数据库中发现了具有特定产品/定制组合的某些语言。 (即，在 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 文件中的四列中有这四个列表。但是，当我现在尝试通过第一行一直向下到 End(xlUp).row 的“For”循环时...它在大约 6,000 个条目后卡住。我的 CPU 处于 99%，Excel 和令人惊讶的内存仍然有大约 1 GB 可用(超出 4 GB)。

我试图在 Stack Overflow 上找到其他解决方案，它引导我找到一个函数来比较两个包含整个列的变体。这是一种 For each x in arr 类型的方法。这也被证明是无用的，因为我的计算机卡住了大约 10,000 个条目。

目标:在我给出的示例中，我的目标是为每种语言制作四个较小的缺失条目列表。在示例中:

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

我对两个主要问题一无所知:

1. 如何有效地比较所有四个列表并确保我的计算机不会崩溃？
2. 如何在我的示例中有效地找到像 7 这样的条目？

(我假设将每个列表与其他每个列表进行比较，直到最终我将 L1 与其他列表进行比较以找到其中大多数缺失的 7 是效率不高的。)

解决方案:我选择了下面的答案并稍微修改了他的代码。

我的计算机在循环中死机了，其中有超过 440,000 个循环，我发现通过在循环中放置一个 DoEvents，这个命令给 Excel 一些空气呼吸'。当它运行此 DoEvents 时，它会执行除当前正在运行的宏之外的所有备份任务，从而允许在宏运行期间编辑 Excel 文件。

另外，最后，在写入缺失项列表时，如果刚刚检查的列表没有缺失，则出现错误，所以我只是使用On Error resume next 以防万一。

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. 将唯一列表与数组匹配以检查缺失值。

代码:

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 之后生成