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

时间:2016-12-16 16:27:47

标签: excel-vba vba excel

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

  

示例:我们有A栏,即“苹果,梨,苹果,梨,橙子”   和B列是“1,2,2,3,1”

     

如果我们将这两列合并,我们会得到Apples1,Pears2,Apples2,   梨3,橘子1。现在,A列中的每一列都应该有一对   B列。基本上,应该存在每种可能的组合。所以我们   缺少Apples3,Pears 1和Oranges2&这些是成对的   这将填写异常报告(在单独的列中)。

在我的电子表格中,我已经有了一些可以让我获得第一步的宏 - 每个可能组合的列表(应该存在于系统中)。但是,我很难找到一个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”),以便只显示例外情况?

1 个答案:

答案 0 :(得分:0)

使用SJR的建议,这就是我想出的内容::

Property(x => x.MyVarcharMaxProperty)
    .HasColumnType("nvarchar(max)");

谢谢!