Excel VBA实现跨工作表复制无表头单列数据并转置粘贴

原代码存在的核心问题 #

• 复制范围选取错误：仅指定了B4单个单元格，未覆盖B列从B4开始的所有有效数据行
• 目标位置逻辑错误：需求是固定以Sheet2的J2单元格为横向粘贴起点，原代码错误通过B列计算纵向粘贴位置
• 缺失转置配置：默认Copy方法不会自动将纵向单列转换为横向行排列
• 无边界校验：当表格仅存在表头无有效数据时，会触发运行时错误
• 未限定工作簿对象：直接调用Worksheets默认指向活动工作簿，跨工作簿运行时容易出现对象指向错误

修正后可直接运行的代码 #

提供两种实现方案，优先推荐无剪贴板的数组赋值方案，运行效率更高：

Sub TransposeColumnData()
    Dim wsCopy As Worksheet
    Dim wsDest As Worksheet
    Dim lCopyLastRow As Long
    Dim copyRng As Range

    ' 绑定数据源、目标工作表
    Set wsCopy = ThisWorkbook.Worksheets("Sheet1")
    Set wsDest = ThisWorkbook.Worksheets("Sheet2")

    ' 定位Sheet1 B列最后一个有数据的单元格行号（表头在B3，有效数据从B4开始）
    lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "B").End(xlUp).Row

    ' 空数据校验：无有效数据时直接退出，避免报错
    If lCopyLastRow < 4 Then
        MsgBox "Sheet1 B列表头下无有效数据，无需复制", vbInformation
        Exit Sub
    End If

    ' 锁定待复制的数据范围
    Set copyRng = wsCopy.Range("B4:B" & lCopyLastRow)

    ' 方案1：数组直接赋值（推荐，不占用剪贴板，大数据量下速度快）
    wsDest.Range("J2").Resize(1, copyRng.Cells.Count).Value = _
        Application.WorksheetFunction.Transpose(copyRng.Value)

    ' ' 方案2：需要保留源单元格格式/公式时启用此段，注释掉上面的赋值代码即可
    ' copyRng.Copy
    ' wsDest.Range("J2").PasteSpecial Paste:=xlPasteAll, Transpose:=True
    ' Application.CutCopyMode = False ' 操作完成后清空剪贴板
End Sub

关键逻辑说明 #

• 转置核心：数组方案通过WorksheetFunction.Transpose实现纵向一维数组转横向一维数组；粘贴特殊方案通过Transpose:=True参数实现转置
• 目标区域自适应：通过Resize(1, copyRng.Cells.Count)根据数据源行数自动调整目标粘贴区域的列数，无论数据源是1行还是上千行，都不会出现多余复制、粘贴错位的问题
• 稳定性优化：用ThisWorkbook限定代码所属工作簿，避免活动工作簿切换导致的对象引用错误；增加空数据校验，兼容表格无有效数据的边界场景

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