复制Excel数据到Word时随机出现Runtime '4605'错误的技术咨询

问题描述 #

编写的VBA宏用于从Excel选定文本模块生成Word报价单，通过循环处理数量不固定的单元格复制。功能可实现，但随机出现Runtime 4605错误，错误发生在wdApp.Selection.Paste行，提示“Selection对象的Paste方法失败”，无规律：同一份模板有时正常运行，有时崩溃；或者在粘贴不同文本块时崩溃。

原代码 #

Option Explicit

Sub CreateQuotation()

    Dim wdApp As Word.Application
    Dim wks1 As Worksheet, wks2 As Worksheet ' 修正变量声明，原代码仅wks2为Worksheet类型
    Dim CopL As Integer, LCounter As Integer, LEnd As Integer, AMachine As Integer, PMachine As Integer
    
    Set wks1 = Sheets("DocumentExtractor")
    Set wks2 = Sheets("Quotation")

    wks1.Cells(11, 65) = 1

    wks1.Calculate
    wks2.Calculate
    
    LCounter = 22
    
    Set wdApp = New Word.Application
    
    With wdApp
        .Visible = True
        .Activate
        
        .Documents.Add "path to template" ' 去掉多余单引号
        .Selection.GoTo -1, , , "ScopeOfSupply"
        
    End With
    
    
    AMachine = wks1.Cells(11, 65)
    
    Do
        
        wks2.Calculate
        wks2.Range("G9:J11").Copy
        wdApp.Selection.Paste
    
        Do
    
            CopL = wks1.Cells(LCounter, 53)
    
            wks2.Range("G" & CopL & ":J" & CopL).Copy
            wdApp.Selection.Paste '<--------------------- 错误发生位置
        
            PMachine = wks1.Cells(LCounter + 1, 47)
            LCounter = LCounter + 1
            
        Loop While AMachine = PMachine
        
        AMachine = AMachine + 1
        wks1.Cells(11, 65) = AMachine
               
    Loop While AMachine <= wks1.Cells(14, 65)
        
    wks1.Cells(11, 65) = 1

End Sub

错误原因分析 #

1. 剪贴板未就绪：复制操作后立即执行Paste，系统剪贴板可能还未完成数据写入，导致Paste方法调用时无数据可用。
2. Selection对象不稳定：Word的Selection依赖当前光标位置，循环中Word可能因自动格式调整、模板内容加载延迟等原因，导致光标位置意外偏移或Selection对象失效。
3. 计算未完成：仅调用wks2.Calculate无法确保异步计算完成，复制的单元格数据可能为空或未更新，粘贴时触发错误。
4. 模板路径错误：原代码中模板路径包含多余单引号，可能导致模板加载异常，间接影响后续Paste操作的稳定性。
5. 变量声明不规范：原代码中Dim wks1, wks2 As Worksheet仅将wks2声明为Worksheet类型，wks1默认是Variant类型，可能导致对象操作不稳定。

修复方案及优化代码 #

核心优化点：

• 用Range对象替代Selection，避免依赖不稳定的光标位置
• 增加剪贴板等待机制，确保复制数据就绪后再粘贴
• 等待Excel计算完全完成
• 规范变量声明
• 添加错误重试机制，处理随机失败的情况

修改后的代码：

Option Explicit

Sub CreateQuotation()

    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    Dim wdTargetRange As Word.Range ' 用Range替代Selection
    Dim wks1 As Worksheet, wks2 As Worksheet
    Dim CopL As Integer, LCounter As Integer, AMachine As Integer, PMachine As Integer
    
    Set wks1 = Sheets("DocumentExtractor")
    Set wks2 = Sheets("Quotation")

    ' 重置变量并等待计算完成
    wks1.Cells(11, 65) = 1
    Application.CalculateUntilAsyncQueriesDone
    LCounter = 22
    
    ' 初始化Word应用和文档
    Set wdApp = New Word.Application
    With wdApp
        .Visible = True
        Set wdDoc = .Documents.Add("path to template") ' 修正路径格式
    End With
    
    ' 定位到目标书签的Range（替代Selection）
    On Error Resume Next
    Set wdTargetRange = wdDoc.Bookmarks("ScopeOfSupply").Range
    On Error GoTo 0
    If wdTargetRange Is Nothing Then
        MsgBox "未找到书签ScopeOfSupply", vbCritical
        wdApp.Quit
        Set wdApp = Nothing
        Exit Sub
    End If
    
    AMachine = wks1.Cells(11, 65)
    
    Do
        Application.CalculateUntilAsyncQueriesDone
        wks2.Range("G9:J11").Copy
        
        ' 粘贴到目标Range并更新Range位置
        PasteWithRetry wdTargetRange
        wdTargetRange.Collapse wdCollapseEnd
        
        Do
            CopL = wks1.Cells(LCounter, 53)
            wks2.Range("G" & CopL & ":J" & CopL).Copy
            
            ' 带重试的粘贴操作
            PasteWithRetry wdTargetRange
            wdTargetRange.Collapse wdCollapseEnd
            
            PMachine = wks1.Cells(LCounter + 1, 47)
            LCounter = LCounter + 1
            
        Loop While AMachine = PMachine
        
        AMachine = AMachine + 1
        wks1.Cells(11, 65) = AMachine
               
    Loop While AMachine <= wks1.Cells(14, 65)
        
    ' 重置变量并清理对象
    wks1.Cells(11, 65) = 1
    Set wdTargetRange = Nothing
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Set wks1 = Nothing
    Set wks2 = Nothing
End Sub

' 带重试机制的粘贴函数，处理随机失败
Sub PasteWithRetry(targetRange As Word.Range)
    Dim retryCount As Integer
    retryCount = 0
    
    Do
        On Error Resume Next
        targetRange.Paste
        On Error GoTo 0
        
        If Err.Number = 0 Then Exit Do
        
        retryCount = retryCount + 1
        If retryCount > 3 Then
            MsgBox "粘贴失败，已重试3次", vbExclamation
            Exit Sub
        End If
        Application.Wait Now + TimeValue("00:00:01") ' 等待1秒后重试
    Loop
End Sub

关键说明 #

• Range替代Selection：通过书签定位固定Range对象，操作更稳定，不会因光标位置变化失效。
• CalculateUntilAsyncQueriesDone：确保Excel所有异步计算完成，避免复制未更新的数据。
• 重试机制：针对剪贴板延迟等随机问题，最多重试3次，提升稳定性。
• 对象清理：最后释放所有对象，避免内存泄漏。

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