VBA跨表移动非相邻列转置至相邻行时触发1004错误求助

问题描述 #

需要将“analysis worksheet”工作表中表头为“Adjusted Score”的非相邻列数据，移动并转置到“final worksheet”工作表从M2开始的相邻行内。使用For Each循环实现时，第二次迭代在c.Select处出现Runtime Error 1004: Select method of Range class failed错误。

需求对应示例：

• 源数据（黄色列为目标列）：
• 目标效果（转置到M2开始的行）：

原代码如下：

Sub move_scores_to_final()
'
' move_scores_to_final Macro
'

'
    Sheets("analysis worksheet").Select
    Range("A1").Select
    
    Dim Rng7 As Range
    Set Rng7 = FindAll(Range("1:1"), "Adjusted Score", xlValues, xlPart, , True)
    
    Rng7.Select
    
    Dim c As Range, sel As Range, i As Integer
    i = 1
    Set sel = Selection
    
    For Each c In sel.Cells
        c.Select
        c.Offset(1, 0).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Sheets("final worksheet").Select
        Range("A1").Offset(i, 12).Select 'this is to make the rows adjacent and i need to put the data starting in column 12
        Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        i = i + 1
    Next c

End Sub

报错原因 #

1. 工作表激活状态冲突：第一次循环执行到Sheets("final worksheet").Select时，当前激活工作表切换为目标表。第二次循环执行c.Select时，c是属于未激活的“analysis worksheet”的Range对象，而Select方法要求操作的Range所在工作表必须是当前激活状态，因此触发1004错误。
2. 过度依赖Select/Selection：这种写法完全依赖工作表和单元格的激活状态，代码稳定性极差，任何手动切换工作表的操作都会导致报错，同时运行效率低下。

修正后的代码 #

直接通过对象引用操作，彻底摒弃Select/Selection，从根源解决问题：

Sub move_scores_to_final()
    Dim wsAnalysis As Worksheet, wsFinal As Worksheet
    Dim Rng7 As Range, c As Range
    Dim lastRow As Long, targetRow As Integer
    
    ' 初始化工作表对象，直接引用无需激活
    Set wsAnalysis = ThisWorkbook.Sheets("analysis worksheet")
    Set wsFinal = ThisWorkbook.Sheets("final worksheet")
    
    ' 查找所有表头为"Adjusted Score"的列
    Set Rng7 = FindAll(wsAnalysis.Range("1:1"), "Adjusted Score", xlValues, xlPart, , True)
    
    ' 未找到目标列时直接退出，避免空对象报错
    If Rng7 Is Nothing Then Exit Sub
    
    targetRow = 2 ' 目标起始行：M2
    For Each c In Rng7.Cells
        ' 获取当前列数据的最后一行（避免End(xlDown)遇到空行提前终止的问题）
        lastRow = wsAnalysis.Cells(wsAnalysis.Rows.Count, c.Column).End(xlUp).Row
        
        ' 仅当列中有数据时执行复制粘贴
        If lastRow >= 2 Then
            wsAnalysis.Range(c.Offset(1), wsAnalysis.Cells(lastRow, c.Column)).Copy
            wsFinal.Cells(targetRow, "M").PasteSpecial Paste:=xlValues, Transpose:=True
        End If
        
        targetRow = targetRow + 1 ' 切换到下一个目标行
    Next c
    
    ' 清除复制状态，释放系统资源
    Application.CutCopyMode = False
End Sub

优化说明 #

• 直接绑定工作表对象，全程不依赖激活状态，代码稳定性大幅提升
• 用Rows.Count结合End(xlUp)获取最后一行，避免原代码中End(xlDown)遇到空行就停止的bug
• 增加空对象判断，防止未找到目标列时触发错误
• 目标行逻辑更直观，直接从M2（行号2）开始计数

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