将Excel中的内容复制粘贴到Word文档中

Question

将Excel中的内容复制粘贴到Word文档中

5

我正在将Excel中的单元格复制到一个打开的Word文档中。我这样做的方法是将单元格的内容复制到剪贴板中，然后替换Word文档中特定的关键词，例如：

如果单元格A1 =“some word”，我需要替换Word文档中的字符串“QUERYA1”。

我是这样做的：

Sub NoFormatPaste()

    wdFind.Replacement.Text = ""
    wdFind.Forward = True
    wdFind.Wrap = wdFindContinue
    wdFind.Execute
    If IsEmpty(Selection.Text) And Len(Selection.Text) = 0 Then
    ClipEmpty.PutInClipboard
    appWd.Selection.PasteSpecial DataType:=wdPasteText
    End
    Else
    appWd.Selection.PasteSpecial DataType:=wdPasteText
    End If
    CutCopyMode = False

End Sub

当这个子程序运行时，它可以处理除空单元格外的所有字段。我在单元格中使用了这个公式：=+IF(K10="XXX","",K10)。当这个公式返回 NOTHING 或空白，并且我运行我的宏时，将其粘贴到 Word 中会出错。我在这一行代码上遇到了一个叫做4168 command failed/command execution 的错误。

appWd.Selection.PasteSpecial DataType:=wdPasteText

这是我的完整代码：

Dim appWd As Word.Application
Dim wdFind As Object
Dim ClipEmpty As New MSForms.DataObject
Dim ClipT As String

Sub FormatPaste()

    wdFind.Replacement.Text = ""
    wdFind.Forward = True
    wdFind.Wrap = wdFindContinue
    wdFind.Execute
    If IsEmpty(Selection.Text) And Len(Selection.Text) = 0 Then
    ClipEmpty.PutInClipboard
    appWd.Selection.Paste
    End
    Else
    appWd.Selection.Paste
    End If
    CutCopyMode = False

End Sub

Sub NoFormatPaste()

    wdFind.Replacement.Text = ""
    wdFind.Forward = True
    wdFind.Wrap = wdFindContinue
    wdFind.Execute
    If IsEmpty(Selection.Text) And Len(Selection.Text) = 0 Then
    ClipEmpty.PutInClipboard
    appWd.Selection.PasteSpecial DataType:=wdPasteText
    End
    Else
    appWd.Selection.PasteSpecial DataType:=wdPasteText
    End If
    CutCopyMode = False

End Sub

Sub CopyDatatoWord()

Dim docWD As Word.Document
Dim sheet1 As Object
Dim sheet2 As Object
Dim SaveCell1 As String
Dim SaveCell2 As String
Dim SaveCell3 As String
Dim Dir1 As String
Dim Dir2 As String


    Set appWd = CreateObject("Word.Application")
    appWd.Visible = True
    'Set docWD = appWD.Documents.Open("S:\Practice Quarterly Reports\2011 Q1 - V5\Practice Profile Template 2011.docx")
    Set docWD = appWd.Documents.Open("C:\Documents and Settings\jhill\Desktop\Practice Profile Template 2011.docx")

    'Select Sheet where copying from in excel
    Set sheet1 = Sheets("TABLES")
    Set sheet2 = Sheets("REPORT INFO")
    Set wdFind = appWd.Selection.Find
    ClipT = "  "
    ClipEmpty.SetText ClipT

    sheet1.Range("B3:B6").Copy
    wdFind.Text = "Qwerty01"
    Call FormatPaste

    sheet1.Range("B10:B15").Copy
    wdFind.Text = "Qwerty02"
    Call FormatPaste

    sheet1.Range("C21:D28").Copy
    wdFind.Text = "Qwerty03"
    Call FormatPaste

    sheet1.Range("B32:F42").Copy
    wdFind.Text = "Qwerty04"
    Call FormatPaste

    sheet1.Range("B46:D52").Copy
    wdFind.Text = "Qwerty05"
    Call FormatPaste

    sheet1.Range("B58:F68").Copy
    wdFind.Text = "Qwerty06"
    Call FormatPaste

    sheet1.Range("B74:G84").Copy
    wdFind.Text = "Qwerty07"
    Call FormatPaste

    sheet1.Range("B87").Copy
    wdFind.Text = "Qwerty08"
    Call NoFormatPaste

    sheet1.Range("B88").Copy
    wdFind.Text = "Qwerty09"
    Call NoFormatPaste

    sheet1.Range("B89").Copy
    wdFind.Text = "Qwerty10"
    Call NoFormatPaste

    sheet1.Range("B90").Copy
    wdFind.Text = "Qwerty11"
    Call NoFormatPaste

    sheet1.Range("B91").Copy
    wdFind.Text = "Qwerty12"
    Call NoFormatPaste

    sheet1.Range("B92").Copy
    wdFind.Text = "Qwerty13"
    Call NoFormatPaste

    sheet1.Range("B93").Copy
    wdFind.Text = "Qwerty14"
    Call NoFormatPaste

    sheet1.Range("B94").Copy
    wdFind.Text = "Qwerty15"
    Call NoFormatPaste

    sheet2.Range("D4").Copy
    wdFind.Text = "Qwerty16"
    Call NoFormatPaste

    sheet2.Range("B5").Copy
    wdFind.Text = "Qwerty17"
    Call NoFormatPaste


    sheet2.Range("D4").Copy
    wdFind.Text = "Qwerty18"
    Call NoFormatPaste

    sheet2.Range("B8").Copy
    wdFind.Text = "Qwerty19"
    Call NoFormatPaste

    sheet2.Range("B9").Copy
    wdFind.Text = "Qwerty20"
    Call NoFormatPaste

    sheet2.Range("B10").Copy
    wdFind.Text = "Qwerty21"
    Call NoFormatPaste

    sheet2.Range("B11").Copy
    wdFind.Text = "Qwerty22"
    Call NoFormatPaste

    sheet2.Range("B12").Copy
    wdFind.Text = "Qwerty23"
    Call NoFormatPaste

    sheet2.Range("B13").Copy
    wdFind.Text = "Qwerty24"
    Call NoFormatPaste

    sheet2.Range("B14").Copy
    wdFind.Text = "Qwerty25"
    Call NoFormatPaste

    sheet2.Range("B15").Copy
    wdFind.Text = "Qwerty26"
    Call NoFormatPaste

    sheet2.Range("B16").Copy
    wdFind.Text = "Qwerty27"
    Call NoFormatPaste

    sheet2.Range("B17").Copy
    wdFind.Text = "Qwerty28"
    Call NoFormatPaste

    sheet2.Range("B5").Copy
    wdFind.Text = "Qwerty29"
    Call NoFormatPaste

    sheet2.Range("B5").Copy
    wdFind.Text = "Qwerty30"
    Call NoFormatPaste

    sheet2.Range("B5").Copy
    wdFind.Text = "Qwerty31"
    Call NoFormatPaste

    SaveCell1 = sheet2.Range("D3").Text
    SaveCell2 = sheet2.Range("B6").Text
    SaveCell3 = SaveCell2 & "\" & SaveCell1

    Dir1 = "\\annapurna\Shared\Practice Quarterly Reports\2011 Q1 - V5\ & SaveCell2"
    Dir2 = "\\annapurna\Shared\Practice Quarterly Reports\2011 Q1 - V5\ & SaveCell3"


    If Len(Dir1) = False Then
    MkDir Dir1
    End If


    'docWD.SaveAs (Dir2 & ".docx")
    docWD.SaveAs ("\\annapurna\Shared\Practice Quarterly Reports\Q1_2011\Test.docx")

    'appWD.Quit

Set appWd = Nothing
Set docWD = Nothing
Set appXL = Nothing
Set wbXL = Nothing

End Sub

我做错了什么？为什么只有在粘贴空白时才会出现错误？

- Alex Gordon

2个回答

3

我在互联网上搜索了所有相关信息，试图找到将Excel中VBA复制的图片粘贴到Word文档中指定位置的方法。虽然找到了一些关于书签等的参考内容，但下面这个单行片段提供了最快速的解决方案。

wrdDoc.Range(Start:=wrdDoc.Paragraphs(p).Range.Start, End:=wrdDoc.Paragraphs(p).Range.End).PasteSpecial Placement:=wdInLine

- Kevin MacKay

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- jordanhill123 · Accepted Answer

以下是代码解决方案：

您需要引用countclipboardformats函数来检查剪贴板上是否有任何内容，然后如果为空，则设置为所选的字符串值。

这似乎是MS剪贴板复制和粘贴功能以及剪贴板功能的故障。

Public Declare Function CountClipboardFormats Lib "user32" () As Long

Dim appWd As Word.Application
Dim wdFind As Object
Dim ClipEmpty As New MSForms.DataObject
Dim ClipT As String

Function IsClipboardEmpty() As Boolean
    IsClipboardEmpty = (CountClipboardFormats() = 0)
End Function

Sub CheckClipBrd()

If IsClipboardEmpty() = True Then
ClipEmpty.PutInClipboard
End If
End Sub

Sub FormatPaste()

    wdFind.Replacement.Text = ""
    wdFind.Forward = True
    wdFind.Wrap = wdFindContinue
    wdFind.Execute
    Call CheckClipBrd
    appWd.Selection.Paste
    CutCopyMode = False

End Sub

Sub NoFormatPaste()

    wdFind.Replacement.Text = ""
    wdFind.Forward = True
    wdFind.Wrap = wdFindContinue
    wdFind.Execute
    Call CheckClipBrd
    appWd.Selection.PasteSpecial DataType:=wdPasteText
    CutCopyMode = False

End Sub

Sub CopyDatatoWord()

Dim docWD As Word.Document
Dim sheet1 As Object
Dim sheet2 As Object
Dim saveCell1 As String
Dim saveCell2 As String
Dim saveCell3 As String
Dim dir1 As String
Dim dir2 As String


    Set appWd = CreateObject("Word.Application")
    appWd.Visible = True
    Set docWD = appWd.Documents.Open("\\annapurna\Shared\Practice Quarterly Reports\Q1_2011\Practice Profile Template 2011.docx")

    'Select Sheet where copying from in excel
    Set sheet1 = Sheets("TABLES")
    Set sheet2 = Sheets("REPORT INFO")
    Set wdFind = appWd.Selection.Find
    ClipT = "  "
    ClipEmpty.SetText ClipT

    sheet1.Range("B3:B6").Copy
    wdFind.Text = "Qwerty01"
    Call FormatPaste

    sheet1.Range("B10:B15").Copy
    wdFind.Text = "Qwerty02"
    Call FormatPaste

    sheet1.Range("C21:D28").Copy
    wdFind.Text = "Qwerty03"
    Call FormatPaste

    sheet1.Range("B32:F42").Copy
    wdFind.Text = "Qwerty04"
    Call FormatPaste

    sheet1.Range("B46:D52").Copy
    wdFind.Text = "Qwerty05"
    Call FormatPaste

    sheet1.Range("B58:F68").Copy
    wdFind.Text = "Qwerty06"
    Call FormatPaste

    sheet1.Range("B74:G84").Copy
    wdFind.Text = "Qwerty07"
    Call FormatPaste

    sheet1.Range("B87").Copy
    wdFind.Text = "Qwerty08"
    Call NoFormatPaste

    sheet1.Range("B88").Copy
    wdFind.Text = "Qwerty09"
    Call NoFormatPaste

    sheet1.Range("B89").Copy
    wdFind.Text = "Qwerty10"
    Call NoFormatPaste

    sheet1.Range("B90").Copy
    wdFind.Text = "Qwerty11"
    Call NoFormatPaste

    sheet1.Range("B91").Copy
    wdFind.Text = "Qwerty12"
    Call NoFormatPaste

    sheet1.Range("B92").Copy
    wdFind.Text = "Qwerty13"
    Call NoFormatPaste

    sheet1.Range("B93").Copy
    wdFind.Text = "Qwerty14"
    Call NoFormatPaste

    sheet1.Range("B94").Copy
    wdFind.Text = "Qwerty15"
    Call NoFormatPaste

    sheet2.Range("D4").Copy
    wdFind.Text = "Qwerty16"
    Call NoFormatPaste

    sheet2.Range("B5").Copy
    wdFind.Text = "Qwerty17"
    Call NoFormatPaste

    sheet2.Range("D4").Copy
    wdFind.Text = "Qwerty18"
    Call NoFormatPaste

    sheet2.Range("B8").Copy
    wdFind.Text = "Qwerty19"
    Call NoFormatPaste

    sheet2.Range("B9").Copy
    wdFind.Text = "Qwerty20"
    Call NoFormatPaste

    sheet2.Range("B10").Copy
    wdFind.Text = "Qwerty21"
    Call NoFormatPaste

    sheet2.Range("B11").Copy
    wdFind.Text = "Qwerty22"
    Call NoFormatPaste

    sheet2.Range("B12").Copy
    wdFind.Text = "Qwerty23"
    Call NoFormatPaste

    sheet2.Range("B13").Copy
    wdFind.Text = "Qwerty24"
    Call NoFormatPaste

    sheet2.Range("B14").Copy
    wdFind.Text = "Qwerty25"
    Call NoFormatPaste

    sheet2.Range("B15").Copy
    wdFind.Text = "Qwerty26"
    Call NoFormatPaste

    sheet2.Range("B16").Copy
    wdFind.Text = "Qwerty27"
    Call NoFormatPaste

    sheet2.Range("B17").Copy
    wdFind.Text = "Qwerty28"
    Call NoFormatPaste

    sheet2.Range("C3").Copy
    wdFind.Text = "Qwerty29"
    Call FormatPaste

    sheet2.Range("C3").Copy
    wdFind.Text = "Qwerty30"
    Call FormatPaste

    sheet2.Range("C3").Copy
    wdFind.Text = "Qwerty31"
    Call FormatPaste

    saveCell1 = sheet2.Range("D3").Text
    saveCell2 = sheet2.Range("B6").Text
    saveCell3 = saveCell2 & "\" & saveCell1

    dir1 = "\\annapurna\Shared\Practice Quarterly Reports\Q1_2011\" & saveCell2
    dir2 = "\\annapurna\Shared\Practice Quarterly Reports\Q1_2011\" & saveCell3


    If Len(dir1) = False Then
    MkDir dir1
    End If


    'docWD.SaveAs (Dir2 & ".docx")
    docWD.SaveAs ("\\annapurna\Shared\Practice Quarterly Reports\Q1_2011\Test.docx")

    'appWD.Quit

Set appWd = Nothing
Set docWD = Nothing
Set appXL = Nothing
Set wbXL = Nothing

End Sub

;) 希望这能帮到你！

(涉及IT技术)