需求：编写VBA宏实现Excel两工作表数据的笛卡尔积合并

需求说明 #

Sheet1共M行，包含任意列数的数据（示例列：ORDER DATE、Region、Reps等）；Sheet2共N行，包含任意列数的数据（示例列：Item、Region、商品数量等）。需要通过VBA宏生成Sheet3，将Sheet1的每一行与Sheet2的所有行逐一组合，最终得到M×N行的笛卡尔积结果。

原代码问题 #

现有代码仅实现了两表列的横向拼接，无法生成每行两两组合的笛卡尔积数据，输出结果不符合需求。原代码如下：

Sub ColumnsPaste()
Dim Source As Worksheet
Dim Destination As Worksheet
Dim Last As Long

Application.ScreenUpdating = False

Set Destination = Worksheets.Add(after:=Worksheets("Sheet1"))
Destination.Name = "Sheet3"

For Each Source In ThisWorkbook.Worksheets        
    If Source.Name <> "Sheet3" Then
        Last = Destination.Range("A1").SpecialCells(xlCellTypeLastCell).Column
    
        If Last = 1 Then
            Source.UsedRange.Copy Destination.Columns(Last)
        Else
            Source.UsedRange.Copy Destination.Columns(Last + 1)
        End If
    End If
Next

Columns.AutoFit

Application.ScreenUpdating = True
End Sub

解决方案VBA代码 #

以下代码支持任意列数的Sheet1和Sheet2，生成正确的笛卡尔积结果：

Sub GenerateCartesianProduct()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim lastRow1 As Long, lastCol1 As Long
    Dim lastRow2 As Long, lastCol2 As Long
    Dim i As Long, j As Long, currentRow As Long
    
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    
    ' 定义工作表对象
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    
    ' 新建Sheet3，若已存在则先删除原有数据
    On Error Resume Next
    Set ws3 = ThisWorkbook.Worksheets("Sheet3")
    If Err.Number <> 0 Then
        Set ws3 = ThisWorkbook.Worksheets.Add(After:=ws2)
        ws3.Name = "Sheet3"
    Else
        ws3.Cells.Clear
    End If
    On Error GoTo 0
    
    ' 获取Sheet1和Sheet2的最后行、列数（自动适配任意列数）
    lastRow1 = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
    lastCol1 = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
    lastRow2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
    lastCol2 = ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column
    
    ' 复制表头：Sheet1表头 + Sheet2表头
    ws1.Range(ws1.Cells(1, 1), ws1.Cells(1, lastCol1)).Copy ws3.Cells(1, 1)
    ws2.Range(ws2.Cells(1, 1), ws2.Cells(1, lastCol2)).Copy ws3.Cells(1, lastCol1 + 1)
    
    currentRow = 2 ' 从第2行开始写入数据
    
    ' 循环生成笛卡尔积
    For i = 2 To lastRow1
        For j = 2 To lastRow2
            ' 复制Sheet1当前行数据到Sheet3
            ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, lastCol1)).Copy ws3.Cells(currentRow, 1)
            ' 复制Sheet2当前行数据到Sheet3对应位置
            ws2.Range(ws2.Cells(j, 1), ws2.Cells(j, lastCol2)).Copy ws3.Cells(currentRow, lastCol1 + 1)
            currentRow = currentRow + 1
        Next j
    Next i
    
    ' 自动调整列宽
    ws3.Columns.AutoFit
    
    ' 恢复屏幕更新并提示完成
    Application.ScreenUpdating = True
    MsgBox "笛卡尔积生成完成，共" & currentRow - 2 & "行数据", vbInformation
End Sub

代码说明 #

1. 工作表处理：自动检测Sheet3是否存在，存在则清空数据，不存在则新建
2. 范围适配：自动获取两表的有效数据范围，支持任意列数的动态适配
3. 表头合并：将两表的表头合并到Sheet3第一行，保持原有列结构
4. 笛卡尔积循环：外层遍历Sheet1数据行，内层遍历Sheet2数据行，逐行组合写入Sheet3
5. 效率优化：关闭屏幕更新避免频繁刷新，提升宏的运行速度

内容的提问来源于stack exchange，提问作者ah Pl