新手求助：使用VBA实现Excel按A列将数据转置为目标格式

嘿，作为VBA新手碰到这种需要按日期分组转置的需求确实有点棘手，我特意给你写了一段带详细注释的代码，你跟着操作就行～

实现思路 #

1. 先从原表A列提取所有唯一日期，作为结果区域的表头（对应你要的H-K列）
2. 把原表中每一行的B-G列内容和对应的日期关联起来
3. 按行把对应日期的内容填充到结果区域，没有匹配项的单元格留空

VBA代码 #

Sub TransposeByDate()
    Dim wsSource As Worksheet, wsResult As Worksheet
    Dim sourceLastRow As Long, sourceLastCol As Long
    Dim uniqueDates As Collection
    Dim dateItem As Variant
    Dim i As Long, j As Long, k As Long
    Dim resultRow As Long
    
    ' 设置源工作表（假设你的数据在Sheet1，可根据实际修改）
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    ' 创建新工作表存放结果，也可以指定现有工作表
    On Error Resume Next
    Set wsResult = ThisWorkbook.Worksheets("TransposedResult")
    If Err.Number <> 0 Then
        Set wsResult = ThisWorkbook.Worksheets.Add
        wsResult.Name = "TransposedResult"
    End If
    On Error GoTo 0
    
    ' 获取源数据的最后一行和最后一列
    sourceLastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    sourceLastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
    
    ' 收集唯一日期
    Set uniqueDates = New Collection
    On Error Resume Next
    For i = 2 To sourceLastRow ' 从第2行开始，假设第1行是表头
        uniqueDates.Add wsSource.Cells(i, "A").Value, Key:=CStr(wsSource.Cells(i, "A").Value)
    Next i
    On Error GoTo 0
    
    ' 写入结果表头（日期）
    resultRow = 1
    For k = 1 To uniqueDates.Count
        wsResult.Cells(resultRow, k + 7).Value = uniqueDates(k) ' 从H列开始（第8列）
    Next k
    
    ' 遍历源数据的每一列（B到G），转置到结果区域
    For j = 2 To sourceLastCol ' B列是第2列，到最后一列
        resultRow = resultRow + 1
        ' 先写入第一组的对应值（作为基准行标识）
        wsResult.Cells(resultRow, 1).Value = wsSource.Cells(2, j).Value
        ' 匹配其他日期的对应值
        For k = 1 To uniqueDates.Count
            ' 查找对应日期的行
            For i = 2 To sourceLastRow
                If wsSource.Cells(i, "A").Value = uniqueDates(k) Then
                    wsResult.Cells(resultRow, k + 7).Value = wsSource.Cells(i, j).Value
                    Exit For
                End If
            Next i
        Next k
    Next j
    
    ' 调整结果列宽，方便查看
    wsResult.Columns.AutoFit
    
    MsgBox "转置完成！结果在工作表" & wsResult.Name & "中", vbInformation
End Sub

操作步骤 #

1. 打开你的Excel文件，确保数据在Sheet1（如果不是，修改代码里的wsSource指向你的目标工作表）
2. 按下Alt + F11打开VBA编辑器
3. 点击菜单栏的插入 -> 模块
4. 把上面的代码粘贴到模块窗口里
5. 按下F5运行代码，或者回到Excel，点击开发工具 -> 宏，选择TransposeByDate执行

如果你的原数据第一行就是数据（没有单独表头），记得把代码里的For i = 2 To sourceLastRow改成For i = 1 To sourceLastRow，同时调整写入表头循环的起始逻辑哦～

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