Excel VBA跨工作表数据复制转置及表头重命名需求

问题核心 #

源数据结构：首行为表头，第1列是唯一ID，第2列是日期，其余列为业务数据；单个ID对应多条日期记录，需转置数据并生成ID Data_1 Date_1 Data_1_2 Date_2 ...格式的自定义表头。

原代码仅针对单个匹配行处理，未覆盖多ID多日期的批量场景，也未实现表头重命名逻辑，因此无法满足需求。

完整实现代码 #

Sub TransposeWithCustomHeaders()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim idDict As Object, currentID As String, rowList As Collection
    Dim dataColCnt As Integer, destRow As Long, j As Integer, k As Integer, m As Integer
    
    ' 指定源表和目标表
    Set srcWS = ThisWorkbook.Sheets("Sheet2")
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    ' 清空目标表（需保留原有数据可注释此行）
    desWS.Cells.Clear
    
    ' 获取源数据边界
    lastRow = srcWS.Cells(srcWS.Rows.Count, 1).End(xlUp).Row
    lastCol = srcWS.Cells(1, srcWS.Columns.Count).End(xlToLeft).Column
    dataColCnt = lastCol - 2 ' 计算业务数据列数量（排除ID、日期列）
    
    ' 用字典分组存储每个ID对应的所有数据行号
    Set idDict = CreateObject("Scripting.Dictionary")
    For k = 2 To lastRow
        currentID = srcWS.Cells(k, 1).Value
        If Not idDict.Exists(currentID) Then
            Set rowList = New Collection
            idDict.Add currentID, rowList
        End If
        idDict(currentID).Add k
    Next k
    
    ' 生成目标表表头
    destRow = 1
    desWS.Cells(destRow, 1).Value = "ID"
    j = 2
    ' 按Data_x_y + Date_y的格式循环生成表头（示例按3个日期，可按需修改）
    For k = 1 To dataColCnt
        For m = 1 To 3
            desWS.Cells(destRow, j).Value = "Data_" & k & "_" & m
            j = j + 1
            desWS.Cells(destRow, j).Value = "Date_" & m
            j = j + 1
        Next m
    Next k
    
    ' 按ID分组转置写入数据
    destRow = 2
    For Each currentID In idDict.Keys
        desWS.Cells(destRow, 1).Value = currentID
        j = 2
        ' 遍历每个业务数据列
        For k = 3 To lastCol
            ' 写入该ID下所有日期对应的数据和日期
            For m = 1 To idDict(currentID).Count
                desWS.Cells(destRow, j).Value = srcWS.Cells(idDict(currentID)(m), k).Value
                j = j + 1
                desWS.Cells(destRow, j).Value = srcWS.Cells(idDict(currentID)(m), 2).Value
                j = j + 1
            Next m
            ' 日期数量不足3个时补空（可选）
            For m = idDict(currentID).Count + 1 To 3
                desWS.Cells(destRow, j).Value = ""
                j = j + 1
                desWS.Cells(destRow, j).Value = ""
                j = j + 1
            Next m
        Next k
        destRow = destRow + 1
    Next currentID
    
    ' 自动适配列宽
    desWS.Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

关键逻辑说明 #

• 数据分组：用Scripting.Dictionary按ID收集对应行号，实现多日期数据的批量处理
• 表头生成：根据业务数据列数和预设日期数（示例为3），循环生成指定格式的自定义表头
• 转置写入：按ID遍历，将每个业务列的多日期数据转置为横向的「数据-日期」对，批量写入目标表
• 性能优化：关闭ScreenUpdating减少界面刷新，提升运行效率

调整提示 #

1. 若源表ID/日期列位置不是第1/2列，修改代码中对应列索引值
2. 单个ID对应的日期数量若不是3，将表头生成和补空循环中的3改为实际最大值
3. 需保留目标表原有数据时，注释desWS.Cells.Clear行，并调整destRow的起始值到目标表空行位置

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