使用VBA同时对两类分组列执行逆透视(Unpivoting)操作

原代码为单维度逆透视逻辑，基于内存数组运算，效率足以支撑大数据量场景。调整列配置和写入逻辑后，即可实现Line组（H-K列）与Color组（N-Q列）按序号配对逆透视，输出独立的Unit Name列和Color列，不会生成跨序号的笛卡尔积冗余行。

核心修改点 #

• 拆分逆透视列为两组独立配置，Line组与Color组按索引一一对应（Line1匹配Color1，Line2匹配Color2，以此类推）
• 调整目标列映射数组，新增第二个逆透视列占位符0，两个0分别对应Unit Name和Color列的输出位置
• 新增Color列标题配置，调整表头和数据写入逻辑，区分两个逆透视列的取值来源
• 保留原代码的非空判断逻辑：仅当对应序号的Line列非空时才生成新行，同步取同序号Color列的值

参考示例 #

• 原始数据结构
  
• 目标输出结构
  

完整可运行代码 #

Option Explicit

Sub TransformData()

    ' 1. 配置参数
    ' s - 源表
    ' d - 目标表
    ' r - 行
    ' c - 列
    ' u - 逆透视列组
    ' v - 固定复制列
    
    ' 源表配置
    Const sName As String = "Sheet1"
    ' 第一组逆透视列：Line1-Line4 对应H-K列（列号8-11）
    Dim suColsLine() As Variant: suColsLine = VBA.Array(8, 9, 10, 11)
    ' 第二组逆透视列：Color1-Color4 对应N-Q列（列号14-17），与Line组按索引严格配对
    Dim suColsColor() As Variant: suColsColor = VBA.Array(14, 15, 16, 17)
    ' 目标列映射规则：数组顺序=目标表从左到右列顺序，元素值=源表对应列号
    ' 0为逆透视列占位符，第一个0对应Unit Name列，第二个0对应Color列
    Dim svCols() As Variant: svCols = VBA.Array(12, 4, 0, 0, 5, 6, 2, 3, 13)
    
    ' 目标表配置
    Const dName As String = "Sheet2"
    Const dFirstCellAddress As String = "A1"
    Const dLineTitle As String = "Unit Name"
    Const dColorTitle As String = "Color"

    ' 2. 引用工作簿
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' 3. 引用源表与数据范围
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion ' 包含表头
    Dim srCount As Long: srCount = srg.Rows.Count ' 包含表头的总行数
    Dim sdrCount As Long: sdrCount = srCount - 1 ' 剔除表头的数据行数
    Dim sdrg As Range: Set sdrg = srg.Resize(sdrCount).Offset(1) ' 纯数据范围
    
    ' 4. 计算目标表行列数
    Dim suUpper As Long: suUpper = UBound(suColsLine)
    Dim drCount As Long: drCount = 1 ' 初始1行表头
    Dim su As Long
    ' 统计有效逆透视数据行数（Line列非空即算有效行）
    For su = 0 To suUpper
        drCount = drCount + sdrCount _
            - Application.CountBlank(sdrg.Columns(suColsLine(su)))
    Next su
    
    Dim svUpper As Long: svUpper = UBound(svCols)
    Dim dcCount As Long: dcCount = svUpper + 1
    
    ' 5. 定义读写数组
    Dim sData As Variant: sData = srg.Value ' 源数据读入内存
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount) ' 定义输出数组
    
    ' 6. 写入表头
    Dim sValue As Variant
    Dim sv As Long
    Dim zeroCount As Long
    zeroCount = 0
    For sv = 0 To svUpper
        If svCols(sv) = 0 Then
            zeroCount = zeroCount + 1
            If zeroCount = 1 Then
                sValue = dLineTitle
            Else
                sValue = dColorTitle
            End If
        Else
            sValue = sData(1, svCols(sv))
        End If
        dData(1, sv + 1) = sValue
    Next sv
    
    ' 7. 写入数据
    Dim dr As Long: dr = 1 ' 表头已写入，从第1行后开始
    Dim sr As Long
    For sr = 2 To srCount
        For su = 0 To suUpper
            sValue = sData(sr, suColsLine(su))
            If Not IsEmpty(sValue) Then ' Line列非空时生成新行
                dr = dr + 1
                zeroCount = 0
                For sv = 0 To svUpper
                    If svCols(sv) = 0 Then
                        zeroCount = zeroCount + 1
                        If zeroCount = 1 Then
                            ' 取对应序号Line值
                            sValue = sData(sr, suColsLine(su))
                        Else
                            ' 取对应序号Color值
                            sValue = sData(sr, suColsColor(su))
                        End If
                    Else
                        ' 取固定列值
                        sValue = sData(sr, svCols(sv))
                    End If
                    dData(dr, sv + 1) = sValue
                Next sv
            End If
        Next su
    Next sr
    
    ' 8. 输出结果到目标表
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    dws.Cells.Clear ' 清空原有数据
    
    With dws.Range(dFirstCellAddress).Resize(, dcCount)
        .Resize(drCount).Value = dData
        ' 基础格式
        .Font.Bold = True
        .EntireColumn.AutoFit
    End With
    
    MsgBox "数据转换完成", vbInformation  
End Sub

调整说明 #

如果需要修改输出列的顺序，直接调整svCols数组内的元素顺序即可：数组从左到右的顺序对应目标表从左到右的列顺序，非0元素填写源表列号即可调整固定列位置，两个0的位置对应Unit Name和Color列的输出位置。

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