如何用Excel VBA宏将多行数据转置为带重复表头的两列？

原表格格式 #

期望输出格式 #

现有问题代码 #

Sub CopyPaste_ValuesTranspose()

Application.ScreenUpdating = False

Dim ws1 As Worksheet, ws2 As Worksheet

Set ws1 = Sheets("Sheet1") '<< source sheet name

Set ws2 = Sheets.Add(after:=Sheets(Sheets.Count)) '<< new Sheet

ws1.Range("A1").CurrentRegion.Copy

ws2.Range("A1").PasteSpecial xlValues, Transpose:=True

Application.CutCopyMode = False

ws2.Cells.EntireColumn.AutoFit

Application.ScreenUpdating = True

End Sub

修改后的VBA代码 #

以下代码会遍历原表的每一行标题，逐个取出该行的所有数据，将标题与数据配对后逐行写入新表：

Sub ConvertTableFormat()
    Application.ScreenUpdating = False
    
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim sourceRange As Range
    Dim rowNum As Long, colNum As Long
    Dim targetRow As Long
    Dim currentHeader As String
    
    ' 设置源工作表和目标工作表
    Set wsSource = Sheets("Sheet1")
    Set wsTarget = Sheets.Add(after:=Sheets(Sheets.Count))
    wsTarget.Name = "ConvertedTable" ' 给新表命名
    
    ' 获取源数据区域
    Set sourceRange = wsSource.Range("A1").CurrentRegion
    
    ' 初始化目标表起始行
    targetRow = 1
    
    ' 遍历源表的每一行
    For rowNum = 1 To sourceRange.Rows.Count
        ' 获取当前行的标题（A列内容）
        currentHeader = sourceRange.Cells(rowNum, 1).Value
        ' 遍历当前行的所有数据列（从第2列开始）
        For colNum = 2 To sourceRange.Columns.Count
            ' 写入标题到目标表A列
            wsTarget.Cells(targetRow, 1).Value = currentHeader
            ' 写入对应数据到目标表B列
            wsTarget.Cells(targetRow, 2).Value = sourceRange.Cells(rowNum, colNum).Value
            ' 目标行号自增
            targetRow = targetRow + 1
        Next colNum
    Next rowNum
    
    ' 自动调整目标表列宽
    wsTarget.Cells.EntireColumn.AutoFit
    
    Application.ScreenUpdating = True
End Sub

代码逻辑说明 #

• 关闭屏幕更新提升运行效率
• 定义源数据工作表与新建的目标工作表
• 遍历源表每一行，提取该行第一列的标题内容
• 针对每一行，从第二列开始遍历所有数据列，将标题与对应数据分别写入目标表的A、B列，每完成一组配对就切换到下一行
• 最后自动调整目标表列宽，恢复屏幕更新

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