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文件的四列中有这四个列表。但是，当我现在尝试一个＆＃39; For＆＃39;循环遍历第一行直到End（xlUp）.row ...它在大约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

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

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

（我假设将每个列表与其他列表进行比较，直到最后我将L1与其他列表进行比较，发现大多数列表中缺少7效率不高。）

解决方案：我选择了以下答案并略微修改了他的代码。

我的计算机在循环期间冻结，其中有超过440,000个循环，我发现通过在循环中放置 DoEvents ，此命令可以提供Excel＆＃ 39;一些空气呼吸＆＃39;。当它运行 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

如果您的计算机一次难以应对所有四个列表，则一次一个可能是权宜之计。你可以像@Sid建议的那样，创建一个包含所有可能值的实例的综合列表，然后一次比较一种语言，将=IF(MATCH(A1,C:C,0)>0,"",)等公式复制到适合的位置，其中ColumnA将是您的主列表， C等每个单独的语言列表。 #N/A将指示ColumnC（等）中缺少ColumnA中的哪个值。

Answer 2

好的，试试吧。这不使用任何公式，因此在Excel上很容易。一切都在记忆中完成。

<强>逻辑：

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

<强>代码：

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

<强>截图：

假设您的列表看起来像这样

enter image description here

运行代码时，输出将在Col J开始生成

enter image description here

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

2 个答案: