Question

我在这里有点棘手。试图简化现有流程。

现有流程：

Word文档（“计划文档模板”）完全由INCLUDETEXT字段组成，这些字段从另一个Word文档（我们称之为“源计划文档”）中提取书签部分，其中包含来自其书签部分的合并字段Excel工作簿（“邮件合并工作簿”）。

当前流程涉及用户复制计划文档模板和邮件合并工作簿，并将其粘贴到他们选择的任何文件夹中。然后，用户填写邮件合并工作簿，保存并关闭，并通过计划文档模板Word文档运行邮件合并。这将从源计划文档中提取已添加书签的部分，具体取决于所选的邮件合并工作簿字段。然后，用户使用CTRL + SHIFT + F9删除所有INCLUDETEXT字段，将Plan Doc Template的字段转换为可用文本。

（希望）未来进程：

用户复制邮件合并工作簿并将其粘贴到其中想要的文件夹填写邮件合并工作簿。（手动步骤）
运行VBA代码。
VBA复制计划文档模板并粘贴到刚刚运行VBA代码的邮件合并工作簿的文件夹中。
VBA根据“邮件合并工作簿”中的字段重命名“计划文档模板Word文档”。
VBA在计划文档模板
VBA突出显示整个文档，按CTRL + SHIFT + F9将字段代码转换为可用文本。

是否可以从Excel VBA代码执行所有这些操作，或者在创建Plan Doc以运行邮件合并并执行CTRL + SHIFT + F9步骤后是否需要单独的代码？

P.S。我通过DDE选择使用Excel工作表从邮件合并工作簿到文档获取正确的格式。希望它也可以包含在VBA代码中。

非常感谢帮助，谢谢，

富

Answer 1

看起来你可以用Excel中的一个宏运行整个事情，而不需要用户运行第二个，使用For循环直到wdApp.Documents.Count增加1.我测试了以下内容，但是只有非常小的数据集，因此它运行得非常快。

由于用户可能不仅仅打开了主合并文档，因此代码可以识别并使用生成的文档。通常，它将成为ActiveDocument，但依赖于它永远不会确定。所以我构建了几个循环来1）将当前打开的文档保存在一个数组中然后2）将它们与当前活动的文档进行比较。如果当前活动的文档不在数组中，则字段取消链接（相当于Ctrl + Shift + F9）。

当然，如果您真的想要从所有文档中识别出新文档，您需要循环每个文档并循环数组，进行比较。但我已经给你起点......

Sub MergeWithWord()
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim nrDocs As Long
    Dim i As Long, d As Long
    Dim aDocs() As Variant

    Set wdApp = GetObject(, "Word.Application")
    nrDocs = wdApp.documents.Count

    'Get all opened documents so can compare whether a new one
    ReDim Preserve aDocs(nrDocs - 1)
    Set wdDoc = wdApp.activedocument
    For i = 0 To nrDocs - 1
        Set aDocs(i) = wdApp.documents(i + 1)
    Next

    If wdDoc.MailMerge.MainDocumentType <> -1 Then
        wdDoc.MailMerge.Destination = 0
        wdDoc.MailMerge.Execute False
        Do Until wdApp.documents.Count > nrDocs Or i > 1000
            i = i + 1
        Loop
        Set wdDoc = wdApp.activedocument
        For d = 0 To UBound(aDocs)
            If wdDoc Is aDocs(d) Then
                Debug.Print "Not a new doc"
            Else
                Debug.Print wdDoc.FullName
                wdDoc.Fields.Unlink
                Exit For
            End If
        Next
    End If

    Debug.Print nrDocs, i
    MsgBox "Done"

End Sub

Answer 2

可能不是最优雅的代码，但这是我用来解决我的问题，以防它帮助其他人。

Sub ButtonMerge()
Dim str1 As String
Dim PlanDocTemplate As String
Dim EDrive As String
Dim answer1 As Integer
Dim answer2 As Integer

answer1 = MsgBox("Is this IC Plan Workbook saved in the appropriate Client folder?", vbYesNo + vbQuestion)

If answer1 = vbNo Then
    MsgBox ("Please save this IC Plan Workbook in the appropriate Client folder then run again.")
    Exit Sub
Else
    'do nothing
End If

str1 = "Q:\IC\New Structure\IC Toolkit\Templates\01 Plan Doc Template\16 Source\IC Plan Doc Template v1.0.docx"
PlanDocTemplate = Application.ActiveWorkbook.Path & "\" & Range("A1").Value & ".docx"
EDrive = "E:\" & Range("A1").Value & ".docx"

If Len(Dir(Application.ActiveWorkbook.Path & "\" & Range("A1").Value & ".docx")) = 0 Then
    Call FileCopy(str1, PlanDocTemplate)
Else
    MsgBox ("The Plan document already exists, please delete or rename the existing Plan Doc in folder " _
    & Application.ActiveWorkbook.Path & "\ before creating a new one.")
    Exit Sub
End If

strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
Worksheets("Data").Activate

'Opens New Plan Doc Template
Set appWD = CreateObject("Word.Application")
appWD.Visible = True

appWD.Documents.Open Filename:=PlanDocTemplate

ActiveDocument.MailMerge.OpenDataSource Name:=strWorkbookName, _
Format:=wdMergeInfoFromExcelDDE, _
ConfirmConversions:=True, _
ReadOnly:=False, _
LinkToSource:=True, _
AddToRecentFiles:=False, _
PasswordDocument:="", _
PasswordTemplate:="", _
Revert:=False, _
Connection:="Entire Spreadsheet", _
SQLStatement:="SELECT * FROM `Data$`", _
SQLStatement1:="", _
SubType:=wdMergeSubTypeOther

appWD.Visible = True

appWD.Selection.WholeStory
appWD.Selection.Fields.Update
appWD.Selection.Fields.Unlink
ActiveDocument.MailMerge.MainDocumentType = wdNotAMergeDocument
appWD.ActiveDocument.Save

Worksheets("Form").Activate
MsgBox "Successfully Created " & Range("A1").Value & " in Location: " & Application.ActiveWorkbook.Path & "\"

answer2 = MsgBox("Do you want to save a draft in the E:\ drive as well?", vbYesNo + vbQuestion, "E: Drive Copy")

If answer2 = vbYes Then
    If Dir("E:\") <> "" Then
        ActiveDocument.SaveAs2 Filename:= _
        "E:\" & Range("A1").Value & ".docx", _
        FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
        AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
        EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
        :=False, SaveAsAOCELetter:=False, CompatibilityMode:=14
        MsgBox ("Successfully Created " & Range("A1").Value & " in E:\ Location.")
        Exit Sub
    Else
        MsgBox ("Please open the E:\ drive and enter your username/password." & _
        vbCrLf & vbCrLf & "Click Ok when E:\ drive is opened.")
        If Len(Dir("E:\")) = 0 Then
            MsgBox ("Error connecting to E:\ drive." & vbCrLf & vbCrLf & "Please ensure you're connected and try again.")
            Exit Sub
        Else
            ActiveDocument.SaveAs2 Filename:= _
            "E:\" & Range("A1").Value & ".docx", _
            FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
            AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
            EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
            :=False, SaveAsAOCELetter:=False, CompatibilityMode:=14
            MsgBox ("Successfully Created " & Range("A1").Value & " in E:\ Location.")
            Exit Sub
        End If
    End If
Else
    Exit Sub
End If

End Sub

Excel工作簿创建Word文档和从Excel工作簿自动运行邮件合并

2 个答案: