Excel VBA如何修改列转行代码将结果输出到同一工作簿新工作表

修改后的完整代码 #

你可以直接替换原有代码使用，核心修改点包括新增新工作表创建逻辑、将输出目标从原工作表改为新工作表、补全所有单元格对象的所属工作表限定避免运行错误：

Option Explicit

Sub colsToRows()
Dim ws1 As Worksheet
' 新增输出工作表变量
Dim wsOut As Worksheet
Dim a As Long, lr As Long, lc As Long
Dim va As Variant, vd As Variant
Dim LastRow As Long, LastCol As Long

        '-- 设定原始数据所在工作表
        Set ws1 = Sheets("Sheet1")
        LastRow = ws1.Range("B" & ws1.Rows.Count).End(xlUp).Row
        ' 补全ws1限定，避免活动页不对时读错数据
        LastCol = ws1.Cells(ws1.Range("C2").Row, ws1.Columns.Count).End(xlToLeft).Column - 1

        '-- 读取表头日期存入数组
        vd = WorksheetFunction.Transpose(WorksheetFunction.Transpose(ws1.Range("C2").Resize(1, LastCol - 1)))

        ' 新增：创建新工作表作为输出页
        Set wsOut = ThisWorkbook.Worksheets.Add(After:=ws1)
        On Error Resume Next ' 避免重命名报错
        wsOut.Name = "转换后结果"
        On Error GoTo 0

        '-- 输出表头到新工作表
        wsOut.Range("A1") = "Item"
        wsOut.Range("B1") = "Dates"
        wsOut.Range("C1") = "Data"

        '-- 遍历原始数据行做行列转换
        For a = 1 To LastRow - 2
           '-- 获取新工作表当前最后一行
            lr = wsOut.Cells(wsOut.Rows.Count, "A").End(xlUp).Row

            '-- 输出项目名称
            va = Array(ws1.Range("B2").Offset(a).Value)
            wsOut.Range("A" & lr + 1).Resize(LastCol - 1) = Application.Transpose(va)

            '-- 输出对应日期
            wsOut.Range("B" & lr + 1).Resize(UBound(vd)) = Application.Transpose(vd)

            '-- 输出对应数值
            va = WorksheetFunction.Transpose(WorksheetFunction.Transpose(ws1.Range("C2").Offset(a).Resize(1, LastCol - 1)))
            wsOut.Range("C" & lr + 1).Resize(UBound(va)) = Application.Transpose(va)
        Next a

End Sub

关键修改说明 #

• 新增了wsOut变量存储输出工作表，代码运行时会自动在原始数据表后面新建名为「转换后结果」的工作表，重复运行也不会报错
• 原代码中所有输出到ws1（原始数据表）的逻辑全部改为输出到wsOut，不会修改原始表的任何内容
• 补全了所有Cells、Range对象的所属工作表限定，即使运行时激活的不是原始数据表也不会出现数据读取错误
• 输出表头从原始表的下方改为新工作表的第一行，结构更清晰

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