Question

我正在处理宏，它可以将数据excel复制并粘贴到word以创建要约信。例如，我们已经有了要约信模板，我们将在其中修改一些细节以推出要约信。你能不能帮我解决这个问题，如果能给我提供新的代码，那将是很大的帮助。

请找到以下代码

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

Dim appWd As Word.Application
Dim wdFind As Object
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 OL As Object  

    Set appWd = CreateObject("Word. Application")
    appWd.Visible = True
    Set docWD = appWd.Documents.Open("\\X:\Users\yuan\Financial Director - Offer Letter.docx")

    'Select Sheet where copying from in excel
    Set OL = Sheets("OL")
    Set wdFind = appWd.Selection.Find
    ClipT = "  "

    OL.Range("B4").Copy
    wdFind.Text = "<Date>"
    Call FormatPaste

    OL.Range("B6").Copy
    wdFind.Text = "Qwerty02"
    Call FormatPaste

    OL.Range("B7").Copy
    wdFind.Text = "Qwerty03"
    Call FormatPaste

    OL.Range("B8").Copy
    wdFind.Text = "Qwerty04"
    Call FormatPaste

    OL.Range("B9").Copy
    wdFind.Text = "Qwerty05"
    Call FormatPaste

    OL.Range("B11").Copy
    wdFind.Text = "Qwerty06"
    Call FormatPaste

    OL.Range("B13").Copy
    wdFind.Text = "Qwerty07"
    Call FormatPaste

    OL.Range("B15").Copy
    wdFind.Text = "Qwerty08"
    Call NoFormatPaste

    OL.Range("B17").Copy
    wdFind.Text = "Qwerty09"
    Call NoFormatPaste

    OL.Range("B18").Copy
    wdFind.Text = "Qwerty10"
    Call NoFormatPaste

    OL.Range("B20").Copy
    wdFind.Text = "Qwerty11"
    Call NoFormatPaste

    OL.Range("B22").Copy
    wdFind.Text = "Qwerty12"
    Call NoFormatPaste

    OL.Range("B24").Copy
    wdFind.Text = "Qwerty13"
    Call NoFormatPaste
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
End Sub

Answer 1

可能有一种更简单的方法可以做到这一点，但我过去所做的就是将WORD模板嵌入到另一个工作表的excel工作簿中。 WORD doc有空书签，我想输入信息。所以我基本上只是打开嵌入式文档，将其空白副本保存到用户的计算机（业务要求以确保我们也使用空白模板），然后打开我们刚刚保存的空白副本并填写它。然后保存。

'opens embedded doc
Set o = .OLEObjects("Object 1")
      o.Verb xlVerbOpen

Dim WDApp As Word.Application
Dim wdDoc2 As Word.Document
Dim nIndex As Integer

Set WDApp = GetObject(, "Word.Application")
Set wdDoc = WDApp.ActiveDocument

'must have already named your FilePath
'saves blank copy of template to the user's computer. will override if one exists.
wdDoc.SaveAs2 FilePath & "temp-name" & ".docx"

'closes out of the original doc. then opens the one we saved to the computer
    wdDoc.Close
    WDApp.Quit

Set WDApp2 = CreateObject("Word.Application")
Set wdDoc2 = WDApp2.Documents.Open(FilePath & "temp=name" & ".docx")
Set objRange = wdDoc2.Bookmarks("Plan").Range

WDApp2.Visible = False
Sheets("Sheet2").Select

'fills out the bookmarks in the doc with values from the worksheet        
    wdDoc2.FormFields("Pol").Result = Range("B2").Value & Range("E2").Value
    wdDoc2.FormFields("Pol2").Result = Range("B2").Value & Range("E2").Value
    wdDoc2.FormFields("Name").Result = Range("C3").Value
    wdDoc2.FormFields("Name2").Result = Range("C3").Value
    wdDoc2.FormFields("Owner").Result = Range("C8").Value
    wdDoc2.FormFields("DueDate").Result = Range("B5").Value
    wdDoc2.FormFields("Amt").Result = Format(Range("B6").Value, "Currency")

'shows the doc so the use could review, and then press OK to save (not required)
WDApp2.Visible = True

    MsgBox "Please Review Letter and Press OK to Continue"

    WDApp2.Visible = False

'saves as a docx and a PDF

    wdDoc2.SaveAs2 FilePath & "filename" & ".docx"

    wdDoc2.SaveAs2 FilePath & "filename" & ".pdf", 17

    wdDoc2.Close
    WDApp2.Quit

    MsgBox "Letter Created Successfully!"

    Set WDApp2 = Nothing
    Set wdDoc2 = Nothing

如果其他所有方法都失败了，也许这可以帮到你。

宏擅长于词

1 个答案: