VBA - Schreiben Sie alle möglichen Kombinationen von 4 Spalten von Daten

Question

Ich habe Skript zum Schreiben aller möglichen Kombinationen für 3 Spalten von Daten gefunden, aber ich versuche, den Code zu ändern, um 4 Spalten und möglicherweise 5 zu schreiben und bin mir nicht sicher, wie. Wenn jemand helfen kann, wäre das großartig! Ich habe versucht, zu tun, was ich denke, sollte arbeiten, indem ich zusätzliche Variablen hinzufüge, wo sie folgen würden (wo ich denke, dass sie logisch gehen würden), aber geting einen "Kompilierungs-Fehler: Ohne Schleife", den ich nicht erklären kann.

Hier ist der Code für die 3 Spalten (ohne meine Änderungen) von User Excellll.

Die Beschreibung des Codes ist hier: "Dieser Code wird die Daten aus den Spalten A, B und C, und geben Sie die Ausgabe, die Sie in den Spalten E, F und G beschrieben."

Sub combinations() 

Dim c1() As Variant 
Dim c2() As Variant 
Dim c3() As Variant 
Dim out() As Variant 
Dim j, k, l, m As Long 


Dim col1 As Range 
Dim col2 As Range 
Dim col3 As Range 
Dim out1 As Range 


Set col1 = Range("A1", Range("A1").End(xlDown)) 
Set col2 = Range("B1", Range("B1").End(xlDown)) 
Set col3 = Range("C1", Range("C1").End(xlDown)) 

c1 = col1 
c2 = col2 
c3 = col3 

Set out1 = Range("E2", Range("G2").Offset(UBound(c1) * UBound(c2) * UBound(c3))) 
out = out1 

j = 1 
k = 1 
l = 1 
m = 1 


Do While j <= UBound(c1) 
    Do While k <= UBound(c2) 
     Do While l <= UBound(c3) 
      out(m, 1) = c1(j, 1) 
      out(m, 2) = c2(k, 1) 
      out(m, 3) = c3(l, 1) 
      m = m + 1 
      l = l + 1 
     Loop 
     l = 1 
     k = k + 1 
    Loop 
    k = 1 
    j = j + 1 
Loop 


out1.Value = out 
End Sub 

Vielen Dank im Voraus für Ihre Hilfe

Answer 1

Für 5 Spalten

Sub combinations() 

    Dim c1() As Variant 
    Dim c2() As Variant 
    Dim c3() As Variant 
    Dim c4() As Variant 
    Dim c5() As Variant 
    Dim out() As Variant 
    Dim j As Long, k As Long, l As Long, m As Long, n As Long, o As Long 


    Dim col1 As Range 
    Dim col2 As Range 
    Dim col3 As Range 
    Dim col4 As Range 
    Dim col5 As Range 
    Dim out1 As Range 


    Set col1 = Range("A1", Range("A1").End(xlDown)) 
    Set col2 = Range("B1", Range("B1").End(xlDown)) 
    Set col3 = Range("C1", Range("C1").End(xlDown)) 
    Set col4 = Range("D1", Range("D1").End(xlDown)) 
    Set col5 = Range("E1", Range("E1").End(xlDown)) 

    c1 = col1 
    c2 = col2 
    c3 = col3 
    c4 = col4 
    c5 = col5 

    Set out1 = Range("G2", Range("K2").Offset(UBound(c1) * UBound(c2) * UBound(c3) * UBound(c4) * UBound(c5))) 
    out = out1 

    j = 1 
    k = 1 
    l = 1 
    m = 1 
    n = 1 
    o = 1 

    Do While j <= UBound(c1) 
     Do While k <= UBound(c2) 
      Do While l <= UBound(c3) 
       Do While m <= UBound(c4) 
        Do While n <= UBound(c5) ' This now loops correctly 
         out(o, 1) = c1(j, 1) 
         out(o, 2) = c2(k, 1) 
         out(o, 3) = c3(l, 1) 
         out(o, 4) = c4(m, 1) 
         out(o, 5) = c5(n, 1) 
         o = o + 1 
         n = n + 1 
        Loop 
        n = 1 
        m = m + 1 
       Loop 
       m = 1 
       l = l + 1 
      Loop 
      l = 1 
      k = k + 1 
     Loop 
     k = 1 
     j = j + 1 
    Loop 


    out1.Value = out 
End Sub 

Für 4 Spalten

Sub combinations() 

    Dim c1() As Variant 
    Dim c2() As Variant 
    Dim c3() As Variant 
    Dim c4() As Variant 

    Dim out() As Variant 
    Dim j As Long, k As Long, l As Long, m As Long, n As Long 


    Dim col1 As Range 
    Dim col2 As Range 
    Dim col3 As Range 
    Dim col4 As Range 

    Dim out1 As Range 


    Set col1 = Range("A1", Range("A1").End(xlDown)) 
    Set col2 = Range("B1", Range("B1").End(xlDown)) 
    Set col3 = Range("C1", Range("C1").End(xlDown)) 
    Set col4 = Range("D1", Range("D1").End(xlDown)) 

    c1 = col1 
    c2 = col2 
    c3 = col3 
    c4 = col4 

    Set out1 = Range("G2", Range("K2").Offset(UBound(c1) * UBound(c2) * UBound(c3) * UBound(c4))) 
    out = out1 

    j = 1 
    k = 1 
    l = 1 
    m = 1 
    n = 1 


    Do While j <= UBound(c1) 
     Do While k <= UBound(c2) 
      Do While l <= UBound(c3) 
       Do While m <= UBound(c4) 
        out(n, 1) = c1(j, 1) 
        out(n, 2) = c2(k, 1) 
        out(n, 3) = c3(l, 1) 
        out(n, 4) = c4(m, 1) 
        n = n + 1 
        m = m + 1 
       Loop 
       m = 1 
       l = l + 1 
      Loop 
      l = 1 
      k = k + 1 
     Loop 
     k = 1 
     j = j + 1 
    Loop 


    out1.Value = out 
End Sub 

Answer 2

Hier ist ein allgemeiner Ansatz, der für eine beliebige Anzahl von Spalten funktionieren soll/Werte (innerhalb des Grundes):

Sub ListCombinations() 

Dim col As New Collection 
Dim c As Range, sht As Worksheet, res 
Dim i As Long, arr, numCols As Long 

    Set sht = ActiveSheet 
    For Each c In sht.Range("A1: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 

Answer 3

Sie können den folgenden Code versuchen, um alle möglichen Kombinationen zu regenerieren (mit Rekursion) ------------------------------ ------------------ Public NextLevel As Ganzzahl

Private Sub CommandButton1_Click() 
    NextLevel = 1 
    Call rrd(1, ActiveSheet.Range("F5"), 1, "") 
End Sub 

Public Function rrd(initiator As Integer, lim As Integer, NextLeg As Integer,  CreatedComb) As Boolean 

    If initiator = lim Then 
     ActiveSheet.Range("G" & NextLevel) = CreatedComb & "," & initiator 
     NextLevel = NextLevel + 1 
    Else 
     If NextLeg < lim Then 
     ActiveSheet.Range("G" & NextLevel) = CreatedComb & "," & initiator 
     NextLevel = NextLevel + 1 
     Call rrd(initiator + 1, lim, initiator + 1, CreatedComb & "," & initiator) 
     End If 
     Call rrd(initiator + 1, lim, initiator, CreatedComb) 
    End If 

End Function