小智 16
我通过通用收集,您希望这可以容纳任意数量的列和每个列中的任意数量的条目.一些变体数组应该提供计算每个值的重复周期所必需的维度.
Option Explicit
Sub main()
Call for_each_in_others(rDATA:=Worksheets("Sheet3").Range("A3"), bHDR:=True)
End Sub
Sub for_each_in_others(rDATA As Range, Optional bHDR As Boolean = False)
Dim v As Long, w As Long
Dim iINCROWS As Long, iMAXROWS As Long, sErrorRng As String
Dim vVALs As Variant, vTMPs As Variant, vCOLs As Variant
On Error GoTo bm_Safe_Exit
appTGGL bTGGL:=False
With rDATA.Parent
With rDATA(1).CurrentRegion
'Debug.Print rDATA(1).Row - .Cells(1).Row
With .Resize(.Rows.Count - (rDATA(1).Row - .Cells(1).Row), .Columns.Count).Offset(2, 0)
sErrorRng = .Address(0, 0)
vTMPs = .Value2
ReDim vCOLs(LBound(vTMPs, 2) To UBound(vTMPs, 2))
iMAXROWS = 1
'On Error GoTo bm_Output_Exceeded
For w = LBound(vTMPs, 2) To UBound(vTMPs, 2)
vCOLs(w) = Application.CountA(.Columns(w))
iMAXROWS = iMAXROWS * vCOLs(w)
Next w
'control excessive or no rows of output
If iMAXROWS > Rows.Count Then
GoTo bm_Output_Exceeded
ElseIf .Columns.Count = 1 Or iMAXROWS = 0 Then
GoTo bm_Nothing_To_Do
End If
On Error GoTo bm_Safe_Exit
ReDim vVALs(LBound(vTMPs, 1) To iMAXROWS, LBound(vTMPs, 2) To UBound(vTMPs, 2))
iINCROWS = 1
For w = LBound(vVALs, 2) To UBound(vVALs, 2)
iINCROWS = iINCROWS * vCOLs(w)
For v = LBound(vVALs, 1) To UBound(vVALs, 1)
vVALs(v, w) = vTMPs((Int(iINCROWS * ((v - 1) / UBound(vVALs, 1))) Mod vCOLs(w)) + 1, w)
Next v
Next w
End With
End With
.Cells(2, UBound(vVALs, 2) + 2).Resize(1, UBound(vVALs, 2) + 2).EntireColumn.Delete
If bHDR Then
rDATA.Cells(1, 1).Offset(-1, 0).Resize(1, UBound(vVALs, 2)).Copy _
Destination:=rDATA.Cells(1, UBound(vVALs, 2) + 2).Offset(-1, 0)
End If
rDATA.Cells(1, UBound(vVALs, 2) + 2).Resize(UBound(vVALs, 1), UBound(vVALs, 2)) = vVALs
End With
GoTo bm_Safe_Exit
bm_Nothing_To_Do:
MsgBox "There is not enough data in " & sErrorRng & " to perform expansion." & Chr(10) & _
"This could be due to a single column of values or one or more blank column(s) of values." & _
Chr(10) & Chr(10) & "There is nothing to expand.", vbInformation, _
"Single or No Column of Raw Data"
GoTo bm_Safe_Exit
bm_Output_Exceeded:
MsgBox "The number of expanded values created from " & sErrorRng & _
" (" & Format(iMAXROWS, "\> #, ##0") & " rows × " & UBound(vTMPs, 2) & _
" columns) exceeds the rows available (" & Format(Rows.Count, "#, ##0") & ") on this worksheet.", vbCritical, _
"Too Many Entries"
bm_Safe_Exit:
appTGGL
End Sub
Sub appTGGL(Optional bTGGL As Boolean = True)
Application.EnableEvents = bTGGL
Application.ScreenUpdating = bTGGL
End Sub
将列标题标签放在第2行,从A列开始,将数据放在第A列的正下方.
我添加了一些错误控件来警告超出工作表上的行数.这通常不是可能考虑的因素,但是将未确定数量的列中的值的数量相乘可以快速产生大量结果.你不会超过1,048,576行是不可预见的.
Par*_*ait 14
非连接选择SQL语句的典型示例,它返回所列表的所有组合结果的笛卡尔积.
SQL数据库解决方案
只需将Animals,Fruit,Country作为单独的表导入任何SQL数据库,如MS Access,SQLite,MySQL等,并列出没有连接的表,包括implicit(WHERE)和explicit(JOIN)连接:
SELECT Animals.Animal, Fruits.Fruit, Countries.Country
FROM Animals, Countries, Fruits;
Excel解决方案
使用ODBC连接到包含动物,国家和水果范围的工作簿,在VBA中运行非连接SQL语句的概念相同.例如,每个数据分组都在自己的同名工作表中.
Sub CrossJoinQuery()
Dim conn As Object
Dim rst As Object
Dim sConn As String, strSQL As String
Set conn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
sConn = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
& "DBQ=C:\Path To\Excel\Workbook.xlsx;"
conn.Open sConn
strSQL = "SELECT * FROM [Animals$A1:A3], [Fruits$A1:A3], [Countries$A1:A3] "
rst.Open strSQL, conn
Range("A1").CopyFromRecordset rst
rst.Close
conn.Close
Set rst = Nothing
Set conn = Nothing
End Sub
Bra*_*cku 12
我对这个问题的第一种方法类似于@Jeeped发布的方法:
- 将输入列加载到数组并计算每列中的行
- 用所有组合填充数组
- 将数组赋给输出范围
使用MicroTimer我计算了上述算法各部分的平均时间.对于更大的输入数据,第3部分占总执行时间的90%-93%.
下面是我尝试提高将数据写入工作表的速度.我定义了一个常数iMinRSize=17.一旦可以iMinRSize使用相同的值填充多个连续的行,代码就会停止填充数组并直接写入工作表范围.
Sub CrossJoin(rSrc As Range, rTrg As Range)
Dim vSrc() As Variant, vTrgPart() As Variant
Dim iLengths() As Long
Dim iCCnt As Integer, iRTrgCnt As Long, iRSrcCnt As Long
Dim i As Integer, j As Long, k As Long, l As Long
Dim iStep As Long
Const iMinRSize As Long = 17
Dim iArrLastC As Integer
On Error GoTo CleanUp
Application.ScreenUpdating = False
Application.EnableEvents = False
vSrc = rSrc.Value2
iCCnt = UBound(vSrc, 2)
iRSrcCnt = UBound(vSrc, 1)
iRTrgCnt = 1
iArrLastC = 1
ReDim iLengths(1 To iCCnt)
For i = 1 To iCCnt
j = iRSrcCnt
While (j > 0) And IsEmpty(vSrc(j, i))
j = j - 1
Wend
iLengths(i) = j
iRTrgCnt = iRTrgCnt * iLengths(i)
If (iRTrgCnt < iMinRSize) And (iArrLastC < iCCnt) Then iArrLastC = iArrLastC + 1
Next i
If (iRTrgCnt > 0) And (rTrg.row + iRTrgCnt - 1 <= rTrg.Parent.Rows.Count) Then
ReDim vTrgPart(1 To iRTrgCnt, 1 To iArrLastC)
iStep = 1
For i = 1 To iArrLastC
k = 0
For j = 1 To iRTrgCnt Step iStep
k = k + 1
If k > iLengths(i) Then k = 1
For l = j To j + iStep - 1
vTrgPart(l, i) = vSrc(k, i)
Next l
Next j
iStep = iStep * iLengths(i)
Next i
rTrg.Resize(iRTrgCnt, iArrLastC) = vTrgPart
For i = iArrLastC + 1 To iCCnt
k = 0
For j = 1 To iRTrgCnt Step iStep
k = k + 1
If k > iLengths(i) Then k = 1
rTrg.Resize(iStep).Offset(j - 1, i - 1).Value2 = vSrc(k, i)
Next j
iStep = iStep * iLengths(i)
Next i
End If
CleanUp:
Application.ScreenUpdating = True
Application.EnableEvents = False
End Sub
Sub test()
CrossJoin Range("a2:f10"), Range("k2")
End Sub
如果我们设置iMinRSize为Rows.Count,则所有数据都写入数组.以下是我的样本测试结果:
如果具有最高行数的输入列首先出现,则代码效果最佳,但修改代码以对列进行排序并按正确顺序处理不是一个大问题.
您可以使用工作表公式执行此操作.如果你有NAME'd范围 - 动物,水果和国家,那么"技巧"就是在该数组中生成索引以提供所有各种组合.
例如:
=CEILING(ROWS($1:1)/(ROWS(Fruits)*ROWS(Countries)),1)
将为Fruits*Countries中的数字条目生成一个基于1的系列数字,这些数字会为您提供每只动物需要的行数.
=MOD(CEILING(ROWS($1:1)/ROWS(Countries),1)-1,ROWS(Fruits))+1
将生成一个基于1的系列,重复每个水果的国家数量.
=MOD(ROWS($1:1)-1,ROWS(Countries))+1))
生成1..n的重复序列,其中n是国家/地区的数量.
将这些放入公式(有一些错误检查)
D3: =IFERROR(INDEX(Animals,CEILING(ROWS($1:1)/(ROWS(Fruits)*ROWS(Countries)),1)),"")
E3: =IF(E3="","",INDEX(Fruits,MOD(CEILING(ROWS($1:1)/ROWS(Countries),1)-1,ROWS(Fruits))+1))
F3: =IF(E3="","",INDEX(Countries,MOD(ROWS($1:1)-1,ROWS(Countries))+1))
