如何使用Excel VBA将每组多行数据集转置合并为单行输出

核心调整思路 #

• 原有代码仅筛选复制包含No.的行，未关联读取对应Code、Date两行的对应值，这是需要调整的核心点
• 直接按源数据每3行为一组的规律遍历读取数据，无需执行整行复制、删除的冗余操作，执行效率更高
• 直接指定写入起始位置为Sheet2的B2单元格，完全匹配需求

适配需求的完整代码 #

Sub TransposeMultiLineData()
    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim lastRow As Long, i As Long, writeRow As Long
    
    ' 指定源数据工作表和目标输出工作表
    Set wsSrc = ThisWorkbook.Worksheets("Sheet1")
    Set wsDest = ThisWorkbook.Worksheets("Sheet2")
    
    ' 获取Sheet1 A列最后一个有数据的行号
    lastRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
    
    ' 写入表头到Sheet2 B1、C1、D1位置
    wsDest.Range("B1") = "No."
    wsDest.Range("C1") = "Code"
    wsDest.Range("D1") = "Date"
    ' 数据写入起始行号为2，对应B2单元格开始写入
    writeRow = 2
    
    ' 按3行一组循环遍历源数据
    For i = 1 To lastRow Step 3
        ' 依次提取当前组No.、Code、Date对应的数值写入目标行
        wsDest.Cells(writeRow, "B") = wsSrc.Cells(i, "B").Value
        wsDest.Cells(writeRow, "C") = wsSrc.Cells(i + 1, "B").Value
        wsDest.Cells(writeRow, "D") = wsSrc.Cells(i + 2, "B").Value
        writeRow = writeRow + 1
    Next i
End Sub

特殊场景适配 #

如果你的源数据组之间存在空行，不是严格3行连续排布，可以将循环部分替换为如下逻辑，通过判断No.标识定位每组起始位置：

For i = 1 To lastRow
    If wsSrc.Cells(i, "A") = "No." Then
        wsDest.Cells(writeRow, "B") = wsSrc.Cells(i, "B").Value
        wsDest.Cells(writeRow, "C") = wsSrc.Cells(i + 1, "B").Value
        wsDest.Cells(writeRow, "D") = wsSrc.Cells(i + 2, "B").Value
        writeRow = writeRow + 1
    End If
Next i

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