Excel宏复制图表至已打开Word文档时遇4160运行时错误求助

日常工作中需手动将Excel图表复制粘贴到Word，因此编写宏实现自动化：制作了带下拉列表的工作簿，可选择已打开的Excel源文件和Word目标文档；宏计划获取文件名后，通过GetObject选择已打开的Word文档，再循环处理测试引用列表批量复制图表。但运行时出现「Run-time error '4160': Application-defined or object-defined error」错误，宏在设置目标Word文档处失败。现有方案多针对新建Word文档，附上宏代码求助解决。

原宏代码 #

Sub ExportCharts()

'Define Excel Variables
Dim TestRef As String
Dim TestType As String
Dim Book1 As Excel.Workbook
Dim Book2 As Excel.Workbook
Dim DisplaySheet As Excel.Worksheet
Dim ChartSheet As Excel.Worksheet
Dim ChartRng As Range
Dim BookName As String
Dim DocName As String
    
'Define Word Variables
Dim WordApp As Object
Dim WordDoc As Object

Set Book1 = Excel.Workbooks("Chart Export.xlsm")

Book1.Activate
Book1.Worksheets("Input").Activate

'Set Book and Doc names
BookName = Book1.Worksheets("Input").Range("E2").Value
DocName = Book1.Worksheets("Input").Range("E5").Value

Set WordApp = GetObject(, "Word.Application")
With WordApp
    .Visible = True
    .Activate
End With

'Set destination document
Set WordDoc = WordApp.Documents("DocName")

'MACRO SEEMS TO BREAK HERE

'Set source workbook
Set Book2 = Excel.Workbooks("BookName")

'Select first test ref
Range("C2").Select

    'Run down list of test refs in order
    Do Until IsEmpty(ActiveCell)
        
        Book1.Activate
        Book1.Worksheets("Input").Activate
    
        'Set test reference and type
        TestRef = ActiveCell.Value
        TestType = Left(TestRef, 1)
    
            'If test type = airborne
            If TestType = "A" Then
            
                Book2.Activate
                
                'Set display and chart worksheets to airborne
                Set DisplaySheet = Book.Worksheets("5 Airborne Display")
                Set ChartSheet = Book.Worksheets("6 Airborne Chart")
                
                DisplaySheet.Activate
            
                'Set test reference in display worksheet
                DisplaySheet.Range("D5") = TestRef
            
                'Activate chart worksheet
                ChartSheet.Activate
                
                'Select chart range in chart worksheet
                Set ChartRng = ChartSheet.Range("A3:AG61")
            
                'Copy chart as picture
                ChartRng.CopyPicture xlScreen, xlBitmap
            
                'Pause Application (helps with stability)
                Application.Wait Now() + #12:00:02 AM#
            
                'Activate destination document
                WordDoc.Activate
                
                'Paste Chart
                WordDoc.Selection.Paste
                
            End If
        
        ActiveCell.Offset(1, 0).Select
    
    Loop
    
End Sub

错误原因及修正方案 #

1. 变量引用错误（核心问题） #

原代码中设置Word文档和Excel工作簿时，错误地将变量名用引号包裹，导致程序试图查找名为"DocName"和"BookName"的文件，而非变量存储的实际文件名：

• 错误写法：Set WordDoc = WordApp.Documents("DocName")
• 正确写法：Set WordDoc = WordApp.Documents(DocName)
• 同理，Set Book2 = Excel.Workbooks(BookName)

2. 未定义对象引用 #

原代码中Set DisplaySheet = Book.Worksheets(...)里的Book未定义，应改为已声明的Book2。

3. 冗余的Activate/Select操作 #

大量使用Activate和Select会增加程序不稳定风险，建议直接通过对象引用操作，避免切换激活状态。

4. 错误处理缺失 #

未处理Word未运行的情况，若Word未打开，GetObject会直接报错，需添加错误捕获逻辑。

5. 等待时间写法优化 #

Application.Wait Now() + #12:00:02 AM#可改为更清晰的Application.Wait Now + TimeValue("00:00:02")。

修正后的完整代码 #

Sub ExportCharts()
    'Define Excel Variables
    Dim TestRef As String
    Dim TestType As String
    Dim Book1 As Excel.Workbook
    Dim Book2 As Excel.Workbook
    Dim DisplaySheet As Excel.Worksheet
    Dim ChartSheet As Excel.Worksheet
    Dim ChartRng As Range
    Dim BookName As String
    Dim DocName As String
    Dim inputWS As Excel.Worksheet
    Dim cell As Range
    
    'Define Word Variables
    Dim WordApp As Object
    Dim WordDoc As Object
    
    'Set reference to the control workbook and input sheet
    Set Book1 = Excel.Workbooks("Chart Export.xlsm")
    Set inputWS = Book1.Worksheets("Input")
    
    'Get source workbook and target document names
    BookName = inputWS.Range("E2").Value
    DocName = inputWS.Range("E5").Value
    
    'Handle Word application - if not running, create new instance
    On Error Resume Next
    Set WordApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        Set WordApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    
    With WordApp
        .Visible = True
    End With
    
    'Set destination document
    On Error Resume Next
    Set WordDoc = WordApp.Documents(DocName)
    If Err.Number <> 0 Then
        MsgBox "目标Word文档未找到：" & DocName, vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    
    'Set source workbook
    On Error Resume Next
    Set Book2 = Excel.Workbooks(BookName)
    If Err.Number <> 0 Then
        MsgBox "源Excel工作簿未找到：" & BookName, vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    
    'Loop through test references without using Select/Activate
    Set cell = inputWS.Range("C2")
    Do Until IsEmpty(cell.Value)
        TestRef = cell.Value
        TestType = Left(TestRef, 1)
        
        'Process airborne test type
        If TestType = "A" Then
            'Set worksheets directly
            Set DisplaySheet = Book2.Worksheets("5 Airborne Display")
            Set ChartSheet = Book2.Worksheets("6 Airborne Chart")
            
            'Update test reference
            DisplaySheet.Range("D5") = TestRef
            
            'Copy chart range as picture
            Set ChartRng = ChartSheet.Range("A3:AG61")
            ChartRng.CopyPicture xlScreen, xlBitmap
            
            'Wait for copy to complete
            Application.Wait Now + TimeValue("00:00:02")
            
            'Paste to Word document (move to end first)
            With WordDoc
                .Content.InsertAfter vbCrLf
                .Content.Select
                .Selection.Paste
            End With
        End If
        
        'Move to next cell
        Set cell = cell.Offset(1, 0)
    Loop
    
    'Cleanup objects
    Set WordDoc = Nothing
    Set WordApp = Nothing
    Set Book2 = Nothing
    Set inputWS = Nothing
    Set Book1 = Nothing
End Sub

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