VBA – 写入4列数据的所有可能的组合
我已经find了编写3列数据的所有可能的组合的脚本，但是我试图修改代码来写4列，可能5，我不知道如何。 如果任何人都可以帮助，这将是伟大的！ 我已经试着做我认为应该通过添加额外的variables，他们会按照（我认为他们会逻辑地），但我geting“编译错误：做不循环”，我不能解释。
这里是用户Excellll的3列（没有我的修改）的代码。
代码的描述在这里：“这段代码将从列A，B和C中获取数据，并给出在E，F和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 在此先感谢您的帮助
对于5列
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
为4列
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
这是一个通用的方法，应该适用于任何数量的列/值（在合理范围内）：
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
您可以尝试下面的代码来重新生成所有可能的组合（使用recursion）————————————公共NextLevel作为整数
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