Excel VBA实现矩阵表转一维表 按区域长度重复粘贴单元格

需求说明 #

• 原始数据为矩阵结构：列对应产品类型（已定义名称区域Products），行对应月度维度（已定义名称区域MonthYear），原始表样例：
  
• 目标是转换为标准一维数据表，目标格式样例：
  
• 最终输出效果参考：
  

现有代码卡点 #

当前已编写的代码可实现按月份数量重复填充产品类型，但无法实现按产品区域长度批量重复填充对应月份值，且代码存在大量Select、逐行遍历、重复复制粘贴的低效逻辑，现有代码如下：

Sub Create_Data_Table()

Dim RowCount As Long
Dim iRange As Range
Dim x As Integer
Dim y As Integer
Dim xy As Integer

Application.ScreenUpdating = False
        
Sheets(1).Activate

x = Range("Products").Count
y = Range("MonthYear").Count

Range("Products").Copy
Sheets(2).Activate

Do While y > 0

    Range("E2").Select
    For Each iRange In Rows
        If Application.CountA(iRange) > 0 Then
            RowCount = RowCount + 1
        End If
    Next

    Range("Products").Copy
    Range("E" & RowCount + 1).Select
    Selection.PasteSpecial xlPasteValues
    
    y = y - 1
    RowCount = 0
Loop

高效实现代码 #

采用内存数组方案处理，无冗余的选中、复制粘贴操作，运行效率远高于逐单元格操作，代码如下：

Sub Create_Data_Table_Optimized()
    Dim arrProduct As Variant, arrMonth As Variant, arrResult As Variant
    Dim i As Long, j As Long, rowIndex As Long
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim productRng As Range, monthRng As Range
    
    ' 配置工作表与命名区域
    Set wsSource = ThisWorkbook.Sheets(1)
    Set wsTarget = ThisWorkbook.Sheets(2)
    Set productRng = wsSource.Range("Products")
    Set monthRng = wsSource.Range("MonthYear")
    
    ' 关闭无关配置提升运行速度
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' 将源数据读入内存数组
    arrProduct = productRng.Value
    arrMonth = monthRng.Value
    
    ' 初始化结果数组：总行数=产品数*月份数，共3列对应产品、月份、指标值
    ReDim arrResult(1 To UBound(arrProduct) * UBound(arrMonth), 1 To 3)
    
    rowIndex = 1
    ' 逐月份循环
    For j = 1 To UBound(arrMonth)
        ' 逐产品循环
        For i = 1 To UBound(arrProduct)
            arrResult(rowIndex, 1) = arrProduct(i, 1)
            arrResult(rowIndex, 2) = arrMonth(j, 1)
            ' 取矩阵交叉位置的数值，可根据实际数据位置调整偏移参数
            arrResult(rowIndex, 3) = wsSource.Cells(monthRng.Row + j - 1, productRng.Column + i - 1).Value
            rowIndex = rowIndex + 1
        Next i
    Next j
    
    ' 写入表头
    wsTarget.Range("A1:C1") = Array("Product Type", "Month/Year", "Unit Data")
    ' 一次性将所有结果写入目标工作表
    wsTarget.Range("A2").Resize(UBound(arrResult), 3).Value = arrResult
    
    ' 恢复Excel默认配置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

使用说明 #

• 代码直接处理内存数组，仅执行一次读、一次写操作，万行级数据也可秒级完成
• 若产品区域为横向排列、月份区域为纵向排列，仅需调整数组取值的维度索引即可，核心双层循环逻辑不变
• 矩阵交叉点取值的偏移参数，可根据实际数值区域相对于命名区域的位置微调即可

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