Неконсолидировать таблицу истинности в Excel

• Вам не нужно указывать столбцы, содержащие комбинированные элементы. Типичная рекурсивная функция может обрабатывать все комбинации без вложенного цикла.

Option Explicit
Sub Demo()
    Dim i As Long, j As Long, c As Variant
    Dim arrData, arrRes, iR As Long, aRow() As Variant
    Dim LastRow As Long, ColCnt As Long
    Dim oSht1 As Worksheet, aTxt
    Dim oColl As New Collection
    Set oSht1 = Sheets("Sheet1") ' modify as needed
    ' load source table
    arrData = oSht1.Range("A1").CurrentRegion.Value
    ColCnt = UBound(arrData, 2)
    ReDim aRow(ColCnt - 1)
    ' loop through each row
    For i = LBound(arrData) + 1 To UBound(arrData)
        ' split all items
        For j = LBound(arrData, 2) To UBound(arrData, 2)
            aRow(j - 1) = Split(arrData(i, j), ",")
        Next j
        GenerateCombinations oColl, aRow
    Next i
    ' populate output
    ReDim arrRes(1 To oColl.Count, ColCnt - 1)
    iR = 0
    For Each c In oColl
        aTxt = Split(c, "|")
        iR = iR + 1
        For j = 0 To UBound(aTxt)
            arrRes(iR, j) = aTxt(j)
        Next
    Next
    ' write output to new sheet
    Sheets.Add
    Range("A1").Resize(, ColCnt).Value = oSht1.Range("A1").Resize(, ColCnt).Value
    Range("A2").Resize(iR, ColCnt).Value = arrRes
End Sub

Sub GenerateCombinations(ByRef oColl As Object, aVals() As Variant, Optional curStr As String = "", Optional colIdx As Long = 0)
    Dim i As Long
    ' If the current index equals the length of the array
    If colIdx = UBound(aVals) + 1 Then
        '        Debug.Print curStr
        oColl.Add Mid(curStr, 2)
        Exit Sub
    End If
    ' Loop through each element in the current array and recursively call GenerateCombinations
    For i = LBound(aVals(colIdx)) To UBound(aVals(colIdx))
        GenerateCombinations oColl, aVals, curStr & "|" & aVals(colIdx)(i), colIdx + 1
    Next i
End Sub

Нерекурсивный подход:

Sub ExpandListing2()

    Dim rw As Range, arr, i As Long, col As Collection, res
    Dim cStart As Range, ws As Worksheet, lr As Long
    
    Set ws = ActiveSheet
    lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
    
    Set cStart = ws.Range("I2") 'output starts here
    
    'process each row in input table
    For Each rw In ActiveSheet.Range("A2:G" & lr).Rows
        arr = rw.Value
        Set col = New Collection
        For i = 1 To UBound(arr, 2)
            col.Add Split(arr(1, i), ",") 'split each cell value to an array (1+ elements)
        Next i
        res = Combine(col)
        'write the result to the sheet
        With cStart.Resize(UBound(res, 1), UBound(res, 2))
            .Value = res
            .Font.Color = IIf(rw.Row Mod 2 = 0, vbBlue, vbRed) 'color this block
        End With
        Set cStart = cStart.Offset(UBound(res, 1)) 'next output start position
    Next rw
End Sub



'Create combinations from a collection of arrays
'return as a 2D array
Function Combine(col As Collection)

    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, v, tmp()

    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
        'handle cases where only one value in a column (not passed in as array)
        If Not TypeName(col(i)) Like "*()" Then
            ReDim tmp(1 To 1)
            tmp(1) = col(i)
            col.Remove i
            If i > col.Count Then
                col.Add tmp
            Else
                col.Add tmp, before:=i
            End If
        End If
        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(1 To t, 1 To numIn) 'resize destination array

    For n = 1 To t
        For i = 1 To numIn
            rv(n, i) = col(i)(pos(i))
        Next i
        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

Пример:

Это также можно сделать с помощью Power Query, доступного в Windows Excel 2010+ и Microsoft 365 (Windows или Mac).

Использование Power Query

• Выберите какую-нибудь ячейку в таблице данных.
• Data => Get&Transform => from Table/Range
• Когда откроется редактор PQ: Home => Advanced Editor
• Запишите имя таблицы в строке 2.
• Вставьте M-код ниже вместо того, что вы видите.
• Измените имя таблицы в строке 2 обратно на то, что было создано изначально.
• Прочтите комментарии и изучите Applied Steps, чтобы понять алгоритм.

let

//Change next line to reflect actual data source
    Source = Excel.CurrentWorkbook(){[Name = "Table3"]}[Content],
    colNames = Table.ColumnNames(Source),
    
//type all columns as text
    #"Changed Type" = Table.TransformColumnTypes(Source,List.Transform(colNames, each {_, type text})),
    
//transform all columns to Lists except for the first column (Assembly #)
    #"Transform to List" = Table.TransformColumns(#"Changed Type", 
        List.Transform(List.RemoveFirstN(colNames,1), (cn)=> {cn, each Text.Split(_,","), type {text}})),

//Expand the lists
    #"Expand Lists" = List.Accumulate(
        Table.ColumnsOfType(#"Transform to List",{type list}),
        #"Transform to List",
        (s,c)=> Table.ExpandListColumn(s,c))
in
    #"Expand Lists"