Excel异常报告 - 创建两个列的所有组合并删除已经存在的所有组合

Question

我正在尝试在Excel中进行异常报告，该报告可用于各种不同的电子表格。这个想法是用户可以输入两个变量，这些变量表明要比较哪两个列。然后，将创建这两个列的所有组合。最后，将将此新列表与现有列表进行比较，并且已经存在的所有组合将从生成的异常报告中删除。

示例：我们的列A是"苹果，梨，苹果，梨，橘子" 和B列是" 1、2、2、3、1"

如果我们结合了这两列，我们会得到apples1，pears2，apples2， 梨3，oranges1。现在，A列的每个都应一对 B列B的基本上，应该存在所有可能的组合。所以我们 缺少Apples3，梨1和Oranges2＆amp;3.这些是对 那将填充异常报告（在单独的列中）。

在我的电子表格中，我已经有了一些宏，可以使我获得第一步 - 每一个可能的组合（应该存在于系统中）的列表。但是，我很难找出一个VBA解决方案，现在可以删除本列表中已经存在的每个结果（从我们的系统中拉出）。

这是宏：

首先是复制两列并将它们粘贴到另一个纸上（以保持原始数据未触及）。然后它删除每列中的重复。

Sub CopyandRemoveDup()
'
' Macro1 Macro
'
'Copy Column 1
    Sheets("Raw Data").Columns("A:A").Select
    Selection.Copy
    Sheets("Inputs & Outputs").Range("C1").PasteSpecial xlPasteValues
    'Need to clean this up
    Sheets("Inputs & Outputs").Columns("C:C").RemoveDuplicates Columns:=1, Header:=xlNo

'Copy Column 2
    Sheets("Raw Data").Columns("B:B").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Inputs & Outputs").Range("D1").PasteSpecial xlPasteValues
    'Need to clean this up
    Sheets("Inputs & Outputs").Columns("D:D").RemoveDuplicates Columns:=1, Header:=xlNo
    Application.CutCopyMode = False
'Be careful without headers
    Sheets("Inputs & Outputs").Range("C1:D1").Delete
End Sub

这个下一个宏实际创建了新列表，并使用以前的宏

中的粘贴列中所有可能的组合

Sub ListCombinations()
Dim col As New Collection
Dim c As Range, sht As Worksheet, res
Dim i As Long, arr, numCols As Long
    Sheets("Inputs & Outputs").Select
    Set sht = ActiveSheet
    For Each c In sht.Range("C1:D1").Cells
        col.Add Application.Transpose(sht.Range(c, c.End(xlDown)))
        numCols = numCols + 1
    Next c
    res = Combine(col, "~~")
    For i = 0 To UBound(res)
        arr = Split(res(i), "~~")
        sht.Range("H1").Offset(i, 0).Resize(1, numCols) = arr
    Next i
End Sub

'create combinations from a collection of string arrays
Function Combine(col As Collection, SEP As String) As String()
    Dim rv() As String
    Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
    Dim t As Long, i As Long, n As Long, ub As Long
    Dim numIn As Long, s As String, r As Long
    numIn = col.Count
    ReDim pos(1 To numIn)
    ReDim lbs(1 To numIn)
    ReDim ubs(1 To numIn)
    ReDim lengths(1 To numIn)
    t = 0
    For i = 1 To numIn  'calculate # of combinations, and cache bounds/lengths
        lbs(i) = LBound(col(i))
        ubs(i) = UBound(col(i))
        lengths(i) = (ubs(i) - lbs(i)) + 1
        pos(i) = lbs(i)
        t = IIf(t = 0, lengths(i), t * lengths(i))
    Next i
    ReDim rv(0 To t - 1) 'resize destination array
    For n = 0 To (t - 1)
        s = ""
        For i = 1 To numIn
            s = s & IIf(Len(s) > 0, SEP, "") & col(i)(pos(i)) 'build the string
        Next i
        rv(n) = s
        For i = numIn To 1 Step -1
            If pos(i) <> ubs(i) Then   'Not done all of this array yet...
                pos(i) = pos(i) + 1    'Increment array index
                For r = i + 1 To numIn 'Reset all the indexes
                    pos(r) = lbs(r)    '   of the later arrays
                Next r
                Exit For
            End If
        Next i
    Next n
    Combine = rv
End Function

如何将列（" C：D"）中的列表与列（" H：I"）中的列表进行比较，并从列（" H：I"）中删除匹配项，以便只显示例外？

Answer 1

使用sjr的建议这是我想出的::

Sub HTH()
    With Range("H1", Cells(Rows.Count, "H").End(xlUp)).Offset(, 2)
        .Formula = "=COUNTIFS('Raw Data'!$A:$A,H1,'Raw Data'!$B:$B,I1)"
        .Value = .Value
    End With
End Sub


Sub DeleteRowBasedOnCriteria()
Dim RowToTest As Long
For RowToTest = Cells(Rows.Count, 3).End(xlUp).Row To 2 Step -1
With Cells(RowToTest, 3)
    If .Value = "1" _
    Then _
    Rows(RowToTest).EntireRow.Delete
End With
Next RowToTest

谢谢！