VBA - 写入4列数据的所有可能组合[重复]
Posted
技术标签:
【中文标题】VBA - 写入4列数据的所有可能组合[重复]【英文标题】：VBA - Write all possible combinations of 4 columns of data [duplicate] 【发布时间】：2013-11-15 19:08:09 【问题描述】：我找到了为 3 列数据编写所有可能组合的脚本，但我正在尝试修改代码以编写 4 列，可能还有 5 列，但我不确定如何。如果有人可以提供帮助，那就太好了！我已经尝试通过添加额外的变量来做我认为应该起作用的事情（我认为他们会在逻辑上进行），但是我得到了一个我无法解释的“编译错误：没有循环”。
这是用户 Excelllll 中 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
提前感谢您的帮助
【问题讨论】：
【参考方案1】：这是一种通用方法，适用于任意数量的列/值（在合理范围内）。
示例用法：
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
'lists begin in A1, B1, C1, D1
For Each c In sht.Range("A1:D1").Cells
col.Add Application.Transpose(sht.Range(c, sht.cells(Rows.Count, c.column).End(xlup)))
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, 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(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
【讨论】：
嗨，蒂姆，感谢您的快速回复 - 在运行代码之前我需要做些什么吗？我试过运行它，它似乎挂断（对我来说）在“构建字符串”评论之后的“Next i”上 @TimWilliams 你能用一个值更新这个代码吗？ @resw67 - 现在应该没问题了【参考方案2】：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
【讨论】：
太棒了！谢谢桑托什 @user2954526 干杯 :)【参考方案3】：您可以尝试以下代码来重新生成所有可能的组合（使用递归）
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
【讨论】：
以上是关于VBA - 写入4列数据的所有可能组合[重复]的主要内容，如果未能解决你的问题，请参考以下文章