求助实现Excel垂直列表数据转横向布局的VBA宏代码

操作步骤 #

• 打开待处理的Excel文件，按Alt + F11唤出VBA编辑器
• 在左侧项目窗口右键点击当前工作簿名称，选择「插入」→「模块」
• 将下方代码复制粘贴到弹出的空白模块窗口中
• 按F5直接运行宏，或关闭VBA编辑器后按Alt + F8选择对应宏名点击执行即可
  注意：运行宏前建议先备份原文件，避免操作失误导致数据丢失无法回退

VBA宏代码 #

Sub 纵向周数据转横向排布()
    Dim lastRow As Long, currentDate As Date, targetCol As Long, i As Long, rowCnt As Long
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    ' 获取B列最后一行有数据的行号
    lastRow = Cells(Rows.Count, "B").End(xlUp).Row
    ' 初始化目标列：首个日期数据保留在B、C列，新日期从D列开始写入
    targetCol = 4
    ' 默认第一行为表头，首个日期从第2行开始读取，无表头可自行修改起始行号
    currentDate = Cells(2, "B").Value
    rowCnt = 2
    
    For i = 2 To lastRow
        ' 检测到新日期则重置行计数
        If Cells(i, "B").Value <> currentDate Then
            currentDate = Cells(i, "B").Value
            rowCnt = 2
        End If
        ' 跳过首个日期的原有B、C列数据
        If targetCol > 4 Or Cells(i, "B").Value <> Cells(2, "B").Value Then
            ' 写入新列的日期和对应数值
            Cells(rowCnt, targetCol).Value = Cells(i, "B").Value
            Cells(rowCnt, targetCol + 1).Value = Cells(i, "C").Value
            rowCnt = rowCnt + 1
            ' 检测到下一组新日期则目标列右移2位
            If i < lastRow And Cells(i + 1, "B").Value <> currentDate Then
                targetCol = targetCol + 2
            End If
        End If
    Next i
    ' 可选功能：清除原B、C列中后续重复的纵向数据，需要时删除行首单引号启用即可
    ' Range(Cells(2 + Application.CountIf(Range("B:B"), Cells(2, "B").Value), "B"), Cells(lastRow, "C")).ClearContents
    Application.ScreenUpdating = True
    MsgBox "数据转换完成！"
End Sub

适配说明 #

• 若表格没有表头，数据从B1单元格开始，将代码中所有起始行参数2修改为1即可正常运行
• 若需要删除原B、C列中冗余的纵向重复数据，取消清除内容代码行的注释即可

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