arrays - 扩展每个列单元格的列单元格

我有3组不同的数据（在不同的列中）


A栏中的动物（5种）
B列中的水果（1000种）
C列中的国家（10种）


对于这3个数据集合，我希望接收5×1000×10的col中的50k对应元素。 E F G（与每种水果和每个国家对应的每种动物）。

可以通过手动复制和粘贴值来完成，但是要花一些时间。有什么办法可以通过VBA代码或

是否有像上面介绍的那样的无限制数据集的通用公式？如果有不清楚的地方请告诉我。

这是一个较小的数据示例，其结果如何显示：

最佳答案

我第一个解决此问题的方法类似于@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，则所有数据都将写入数组。以下是我的示例测试结果：



如果输入行数最多的输入列排在最前面，则代码效果最佳，但是修改代码以对列进行排序并以正确的顺序处理并不是什么大问题。