excel - todas - generador de combinaciones sin repeticion

VBA-Escribe todas las combinaciones posibles de 4 columnas de datos

Question

He encontrado un script para escribir todas las combinaciones posibles para 3 columnas de datos, pero estoy tratando de modificar el código para escribir 4 columnas y posiblemente 5 y no estoy seguro de cómo. ¡Si alguien puede ayudar sería genial! Intenté hacer lo que creo que debería funcionar agregando variables adicionales a las que seguirían (donde creo que irían lógicamente) pero estoy generando un "Error de compilación: No hacer ciclo" que no puedo explicar.

Aquí está el código para las 3 columnas (sin mis modificaciones) de User Excellll.

La descripción del código está aquí: "Este código tomará los datos de las columnas A, B y C, y dará el resultado que describió en las columnas E, F y G."

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

Gracias de antemano por tu ayuda

Answer 1

Aquí hay un enfoque genérico que debería funcionar para cualquier cantidad de columnas / valores (dentro de lo razonable):

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 2

Hay un error en la combinación x5 , se usa c4 lugar de c5 (la segunda línea se muestra a continuación):

Do While m <= UBound(c4)
Do While n <= UBound(c4)

Answer 3

Para 5 columnas

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

Para 4 columnas

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 4

Puede probar el siguiente código para regenerar todas las combinaciones posibles (usando recursión) ------------------------------------ ------------ Public NextLevel As Integer

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