VBA实现Word文本粘贴到Excel时如何避免运行时错误1004

问题描述 #

需要通过VBA实现如下功能：将Excel工作表中的两段文本导出至Word，调用Word的文档比较功能标记两段文本的差异（为差异内容添加高亮、下划线格式），再将带格式的最终文本导回Excel工作表。

代码按列逐行执行过程中，有时执行到ActiveSheet.Paste语句会触发如下报错：

Run-time error '1004':
Microsoft Excel cannot paste the data.

原有功能实现代码 #

Dim previous As String: previous = Cells(i, 19).Value
Dim current As String: current = Cells(i, 20).Value

Dim wordApp As Word.Application: Set wordApp = New Word.Application
wordApp.Visible = True

Dim firstdoc As Word.Document: Set firstdoc = wordApp.Documents.Add
firstdoc.Paragraphs(1).Range.Text = previous

Dim seconddoc As Word.Document: Set seconddoc = wordApp.Documents.Add
seconddoc.Paragraphs(1).Range.Text = current

Dim lastdoc As Word.Document
Set lastdoc = wordApp.CompareDocuments(firstdoc, seconddoc, wdCompareDestinationNew)
With lastdoc.ActiveWindow.View.RevisionsFilter
    .Markup = wdRevisionsMarkupAll
    .View = wdRevisionsViewFinal
End With

lastdoc.Content.FormattedText.Copy

Cells(i, 20).Activate
Cells(i, 20).Select
PAUSE 3
ActiveSheet.Paste '程序经常在这一步异常中断

firstdoc.Close SaveChanges:=wdDoNotSaveChanges
seconddoc.Close SaveChanges:=wdDoNotSaveChanges
lastdoc.Close SaveChanges:=wdDoNotSaveChanges
wordApp.Visible = False

报错触发后点击调试，按下F5（继续）程序即可恢复正常运行。处理30行文本的过程中该错误会随机出现5-6次，与待处理文本长度无关，长、短文本粘贴场景下均可能触发。此前添加PAUSE 3子程序降低运行速度等待Excel响应，仅降低了错误出现频率，未彻底解决问题。

用到的PAUSE子程序代码如下：

Sub PAUSE(Period As Single)
Dim t As Single
Period = 0.5
t = Timer + Period
Do
    DoEvents
Loop Until t < Timer
End Sub

错误触发原因 #

1. 跨进程剪贴板竞态问题：从Word复制带格式内容到Excel属于跨进程剪贴板操作，Copy方法返回时Word并不一定已经把完整的格式化数据写入系统剪贴板，如果此时Excel立刻执行粘贴操作，剪贴板内没有可识别的粘贴数据，就会抛出1004错误。
2. 等待子程序逻辑错误：现有PAUSE子程序内部硬编码将传入的Period参数重置为0.5，调用PAUSE 3时实际仅等待0.5秒，远达不到等待剪贴板同步的效果；且固定时长等待无法适配不同设备的性能差异，无法覆盖所有同步延迟场景。
3. COM对象频繁创建销毁：逐行循环时每次都新建、销毁Word应用实例，频繁的COM对象调度会占用大量系统资源，拖慢跨进程通信速度，进一步提升剪贴板同步失败的概率。
4. 粘贴写法不稳定：ActiveSheet.Paste依赖单元格选中激活状态，容易受界面刷新、窗口焦点变化影响，稳定性差。

修复方案 #

1. 修正PAUSE子程序逻辑，移除内部硬编码的参数赋值，保证等待时长符合调用预期。
2. 将Word实例创建逻辑移到循环外，所有行处理完成后再统一销毁，减少不必要的资源开销。
3. 替换不稳定的选中+ActiveSheet.Paste写法，直接对目标单元格区域执行粘贴操作。
4. 增加粘贴重试机制：不使用固定等待时长，而是检测粘贴结果，失败则短间隔重试，直到粘贴成功或达到最大重试次数，彻底解决异步同步问题。

修复后参考代码 #

' 修正后的等待子程序
Sub PAUSE(Period As Single)
    Dim t As Single
    t = Timer + Period
    Do
        DoEvents
    Loop Until Timer >= t
End Sub

Sub TextCompareAndPaste()
    Dim wordApp As Word.Application
    Dim firstdoc As Word.Document, seconddoc As Word.Document, lastdoc As Word.Document
    Dim previous As String, current As String
    Dim targetRng As Range
    Dim i As Long, retryCount As Long
    
    ' 循环外一次性创建Word实例，后台运行
    Set wordApp = New Word.Application
    wordApp.Visible = False
    
    ' 按实际数据范围修改循环起止行，示例为第2行到第31行共30行数据
    For i = 2 To 31
        previous = Cells(i, 19).Value
        current = Cells(i, 20).Value
        Set targetRng = Cells(i, 20)
        
        ' 新建临时对比文档
        Set firstdoc = wordApp.Documents.Add
        firstdoc.Paragraphs(1).Range.Text = previous
        Set seconddoc = wordApp.Documents.Add
        seconddoc.Paragraphs(1).Range.Text = current
        
        ' 执行文档对比
        Set lastdoc = wordApp.CompareDocuments(firstdoc, seconddoc, wdCompareDestinationNew)
        With lastdoc.ActiveWindow.View.RevisionsFilter
            .Markup = wdRevisionsMarkupAll
            .View = wdRevisionsViewFinal
        End With
        
        ' 复制带格式的对比结果
        lastdoc.Content.FormattedText.Copy
        
        ' 提前关闭临时文档释放资源
        firstdoc.Close SaveChanges:=wdDoNotSaveChanges
        seconddoc.Close SaveChanges:=wdDoNotSaveChanges
        
        ' 重试粘贴：最多重试5次，每次间隔0.3秒
        retryCount = 0
        Do
            On Error Resume Next
            targetRng.PasteSpecial xlPasteAll ' 保留全部格式粘贴
            If Err.Number = 0 Then Exit Do
            Err.Clear
            retryCount = retryCount + 1
            PAUSE 0.3
        Loop While retryCount < 5
        On Error GoTo 0
        
        ' 关闭对比结果文档，清空剪贴板
        lastdoc.Close SaveChanges:=wdDoNotSaveChanges
        Application.CutCopyMode = False
    Next i
    
    ' 所有任务完成后退出Word进程，释放对象
    wordApp.Quit SaveChanges:=wdDoNotSaveChanges
    Set wordApp = Nothing
End Sub

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