将多个单元格从 Excel 复制/粘贴到 Word 时出现“随机”错误 4605

Question

我正在努力实现原本需要手写的纸质文档的自动化。我有一个带有书签的 Word 模板，然后使用 Excel 中的 vba 代码找到并粘贴这些书签。我的问题是，随机地，我会收到错误 4605 剪贴板中没有任何内容或格式错误。如果我重新运行代码，它通常会运行良好。我认为问题是由于剪贴板被填满或其他原因造成的，因此我添加了一些在网上找到的行，以在每次迭代和开始循环之前清除剪贴板。错误仍然出现，我认为我的代码可能存在其他问题，这是我第一次使用 VBA。

Sub CreateWordDoc()
    Dim wdApp As Word.Application
    Dim SaveAsName As String
    Dim xAutoWrapper As Object
    Dim x As Long
    
    Set wdApp = New Word.Application
    Set xAutoWrapper = New DataObject
    
    With wdApp
    '.Visible = True
    '.Activate
    
    '.Documents.Add "C:\Users\UserName\Desktop\Rain Delay Letter Template Rev 10.dotx"
    ccc
    For x = 7 To 50
        If Range("V" & x).Value <> "N/A" Then
        .Documents.Add "C:\Users\SPringle\Desktop\Rain Delay Letter Template Rev 10.dotx"
        Range("D1").Copy
        .Selection.Goto wdGoToBookmark, , , "LetterDate"
        .Selection.PasteSpecial xlPasteValues
       
        Range("Y" & x).Copy
        .Selection.Goto wdGoToBookmark, , , "Address"
        .Selection.PasteSpecial xlPasteValues
                Debug.Print Err.Number
        Range("X" & x).Copy
        .Selection.Goto wdGoToBookmark, , , "Client"
        .Selection.PasteSpecial xlPasteValues
        
        Range("W" & x).Copy
        .Selection.Goto wdGoToBookmark, , , "Contact"
        .Selection.PasteSpecial xlPasteValues
        
        xAutoWrapper.SetText Range("Z" & x).Text
        xAutoWrapper.PutInClipboard
        .Selection.Goto wdGoToBookmark, , , "LastName"
        .Selection.PasteSpecial xlPasteValues
        
        Range("U" & x).Copy
        .Selection.Goto wdGoToBookmark, , , "Dates"
        .Selection.PasteSpecial xlPasteValues

        Range("V" & x).Copy
        .Selection.Goto wdGoToBookmark, , , "Amounts"
        .Selection.PasteSpecial xlPasteValues
        
        Range("B" & x).Copy
        .Selection.Goto wdGoToBookmark, , , "ProjectName"
        .Selection.PasteSpecial xlPasteValues
        
        Range("D" & x).Copy
        .Selection.Goto wdGoToBookmark, , , "PM"
        .Selection.PasteSpecial xlPasteValues
        
        Range("AA" & x).CopyPicture Appearance:=xlScreen, Format:=xlPicture
        .Selection.Goto wdGoToBookmark, , , "Signature"
        .Selection.Paste
        
        SaveAsName = Environ("UserProfile") _
        & "\Desktop\RainLetters\Rain Delay - " _
        & Range("B" & x).Value & " " & Range("I1").Value & ".docx"
        
        .ActiveDocument.SaveAs2 SaveAsName
        .ActiveDocument.Close
        End If
        ccc
        Next x
End With
MsgBox ("Letters are complete!")
End Sub

Option Explicit
Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As LongPtr
Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As LongPtr
Public Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr

Public Function ClearClipboard()
    OpenClipboard (0&)
    EmptyClipboard
    CloseClipboard
End Function

Sub ccc()
    Call ClearClipboard
End Sub

Answer 1

您无需从 Excel 复制值并将值粘贴到 Word 中。在 Word 中使用

Selection.TypeText

效果更好。在应用程序之间复制和粘贴会占用更多系统资源。

        .Selection.GoTo wdGoToBookmark, , , "LetterDate"
        .Selection.TypeText Text:=Range("D1").Value 

上面的代码片段实现了与您的代码相同的结果。

        Range("D1").Copy
        .Selection.GoTo wdGoToBookmark, , , "LetterDate"
        .Selection.PasteSpecial xlPasteValues

Answer 2

您可以直接从范围内设置书签文本，正如taller_Excelhome 已经指出的那样。将该进程包装到一个单独的子进程中会更干净。

Sub CreateWordDoc()
    Dim wdApp As Word.Application, doc As Word.Document
    Dim SaveAsName As String
    Dim x As Long, ws As Worksheet
    
    Set ws = ThisWorkbook.Worksheets("Data") 'for example
    Set wdApp = New Word.Application
    wdApp.Visible = True
    
    For x = 7 To 50
        If ws.Range("V" & x).Value <> "N/A" Then
            
            Set doc = wdApp.Documents.Add("C:\Users\SPringle\Desktop\Rain Delay Letter Template Rev 10.dotx")
            doc.SaveAs2 SaveAsName
            
            SetBookmarkText doc, "LetterDate", ws.Range("D1").Value
            SetBookmarkText doc, "Address", ws.Cells(x, "Y").Value
            SetBookmarkText doc, "Client", ws.Cells(x, "X").Value
            SetBookmarkText doc, "Contact", ws.Cells(x, "W").Value
            SetBookmarkText doc, "LastName", ws.Cells(x, "Z").Value
            SetBookmarkText doc, "Dates", ws.Cells(x, "U").Value
            SetBookmarkText doc, "V", ws.Cells(x, "Amounts").Value
            SetBookmarkText doc, "ProjectName", ws.Cells(x, "B").Value
            SetBookmarkText doc, "PM", ws.Cells(x, "D").Value
            SetBookmarkText doc, "AA", ws.Cells(x, "Signature").Value
            
            SaveAsName = Environ("UserProfile") _
                    & "\Desktop\RainLetters\Rain Delay - " _
                    & ws.Range("B" & x).Value & " " & ws.Range("I1").Value & ".docx"
            
            doc.Close savechanges:=True
        End If 'V value not N/A
    Next x
    MsgBox ("Letters are complete!")
End Sub

'set the text for a bookmark, preserving the bookmark
Sub SetBookmarkText(doc As Word.Document, bmName As String, v)
    Dim rng As Word.Range
    Set rng = doc.Bookmarks(bmName).Range  'get the range
    rng.Text = v                           'set the text (note this will delete the bookmark)
    doc.Bookmarks.Add bmName, rng          'recreate bookmark
End Sub