替换ThisWorkbook.Activate为wb.Activate时触发下标越界错误

我是VBA新手，这可能是个简单问题，但搜索后未找到答案。我有一个Sub过程，使用ThisWorkbook.Activate时运行正常，但替换为直接引用工作簿后无法运行，无法查明原因。

版本信息：Microsoft® Excel® for Microsoft 365 MSO (Version 2501 Build 16.0.18429.20132) 64位

非可运行代码 #

Sub Paste_Columns()

 Application.ScreenUpdating = False
 Application.EnableEvents = False
 Application.DisplayAlerts = False
 Application.Calculation = xlCalculationManual
    
    Dim tgtWB As Workbook
    Dim tgtFilePath As String
    Dim cell As Range
    Dim lastRow As Long
    Dim srcWB As Workbook
    Dim srcFilePath As String
    
    tgtFilePath = "\\location.com\tgtFile.xlsx"
    srcFilePath = "https://org-my.sharepoint.com/personal/Documents/Desktop/srcFile.xlsm"
    
    Set tgtWB = Workbooks.Open(tgtFilePath)
    Set srcWB = Workbooks(srcFilePath)
    
    srcWB.Activate
    
    Union(Range("Tbl1[[#Headers],[#Data],[Column3]]"), _
            Range("Tbl1[[#Headers],[#Data],[Column6]]"), _
            Range("Tbl1[[#Headers],[#Data],[Column8]]"), _
            Range("Tbl1[[#Headers],[#Data],[Column12]]")).Select
    Selection.Copy

    tgtWB.Worksheets(4).Activate
    Range("A1").Activate
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    
    Dim tbl As ListObject
    Dim rng As Range

    Set rng = Range(Range("A1"), Range("A1").SpecialCells(xlLastCell))
    Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)
    tbl.TableStyle = "TableStyleMedium2"
        

End Sub

可运行代码 #

Sub Paste_Columns()

 Application.ScreenUpdating = False
 Application.EnableEvents = False
 Application.DisplayAlerts = False
 Application.Calculation = xlCalculationManual
    
    Dim tgtWB As Workbook
    Dim tgtFilePath As String
    Dim cell As Range
    Dim lastRow As Long
    Dim srcWB As Workbook
    Dim srcFilePath As String
    
    tgtFilePath = "\\location.com\tgtFile.xlsx"
    srcFilePath = "https://org-my.sharepoint.com/personal/Documents/Desktop/srcFile.xlsm"
    
    Set tgtWB = Workbooks.Open(tgtFilePath)
    Set srcWB = Workbooks.Open(srcFilePath)
    
    ThisWorkbook.Activate
    
    Union(Range("Tbl1[[#Headers],[#Data],[Column3]]"), _
            Range("Tbl1[[#Headers],[#Data],[Column6]]"), _
            Range("Tbl1[[#Headers],[#Data],[Column8]]"), _
            Range("Tbl1[[#Headers],[#Data],[Column12]]")).Select
    Selection.Copy

    tgtWB.Worksheets(4).Activate
    Range("A1").Activate
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    
    Dim tbl As ListObject
    Dim rng As Range

    Set rng = Range(Range("A1"), Range("A1").SpecialCells(xlLastCell))
    Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)
    tbl.TableStyle = "TableStyleMedium2"
        

End Sub

问题原因与修正方案 #

1. 工作簿引用错误 #

非可运行代码中Set srcWB = Workbooks(srcFilePath)是错误用法：Workbooks集合的索引只能是**工作簿名称（不含路径）**或索引序号，不能直接用完整文件路径。必须用Workbooks.Open(srcFilePath)打开工作簿（与可运行代码一致），若工作簿已打开，可使用Workbooks("srcFile.xlsm")引用。

2. 未明确指定Range的父对象 #

即使执行srcWB.Activate，Range("Tbl1[...]")仍默认指向当前活动工作表，若Tbl1不在srcWB的活动工作表中，会因找不到表报错。正确做法是直接指定表所属的工作表和工作簿，避免依赖Activate和Select（这类操作易出错且降低代码效率）。

3. 避免使用Activate/Select #

VBA中应尽量摒弃Activate和Select操作，直接对目标对象进行操作更可靠。

修正后的代码 #

Sub Paste_Columns()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    
    Dim tgtWB As Workbook
    Dim tgtFilePath As String
    Dim srcWB As Workbook
    Dim srcFilePath As String
    Dim srcTbl As ListObject
    Dim tgtWs As Worksheet
    Dim copyRng As Range
    
    tgtFilePath = "\\location.com\tgtFile.xlsx"
    srcFilePath = "https://org-my.sharepoint.com/personal/Documents/Desktop/srcFile.xlsm"
    
    ' 打开目标工作簿
    Set tgtWB = Workbooks.Open(tgtFilePath)
    ' 打开源工作簿（需确保Excel有权限访问该SharePoint路径）
    Set srcWB = Workbooks.Open(srcFilePath)
    
    ' 明确指定源表所在工作表（假设Tbl1在srcWB的第一个工作表，需根据实际修改）
    Set srcTbl = srcWB.Worksheets(1).ListObjects("Tbl1")
    
    ' 直接获取需复制的列区域，无需Select
    Set copyRng = Union(srcTbl.ListColumns("Column3").Range, _
                        srcTbl.ListColumns("Column6").Range, _
                        srcTbl.ListColumns("Column8").Range, _
                        srcTbl.ListColumns("Column12").Range)
    
    ' 明确指定目标工作表
    Set tgtWs = tgtWB.Worksheets(4)
    
    ' 直接粘贴，无需Activate和Select
    copyRng.Copy
    tgtWs.Range("A1").PasteSpecial Paste:=xlPasteValues
    tgtWs.Range("A1").PasteSpecial Paste:=xlPasteFormats
    
    ' 创建表格，明确指定父工作表
    Dim tbl As ListObject
    Dim rng As Range
    Set rng = tgtWs.Range(tgtWs.Range("A1"), tgtWs.Range("A1").SpecialCells(xlLastCell))
    Set tbl = tgtWs.ListObjects.Add(xlSrcRange, rng, , xlYes)
    tbl.TableStyle = "TableStyleMedium2"
    
    ' 恢复Excel默认设置
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
End Sub

关键改进点 #

• 所有对象（工作簿、工作表、列表对象、单元格区域）均明确指定父对象，消除对活动对象的依赖
• 移除所有Activate和Select操作，直接操作目标对象
• 增加Excel环境设置的恢复代码，避免影响后续操作
• 使用列表对象的ListColumns属性直接获取列区域，比结构化引用更可靠

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