顯示一個列表來選擇word文檔，然後一個宏將合併信息從excel到word

Question

這是我的宏與word合併。 我意識到我需要做更多的事情，從一系列可用的單詞文檔合併（xx1，xx2 ... xx7）中獲得提示。有6個單詞文檔，其中2個需要打開另一個常用單詞文檔（xx7）。即。當我選擇單詞文檔xx3或xx6時，我需要打開2個單詞文檔。如果我選擇xx3 word文檔，則會打開xx3和xx7，如果選擇xx6 word文檔，則會打開xx6和xx7。在此期間，xx1，xx2，xx4，xx5將打開一個單詞文檔。 我不想重複這個宏7次與其他單詞文檔名稱。任何機會我可以得到這個覆蓋在一個宏？謝謝

Sub RunMergeAttachBOccupantProtection() 

    Const wdFormLetters = 0 
    wdOpenFormatAuto = 0 
    Const wdSendToNewDocument = 0 
    wdDefaultFirstRecord = 1 
    wdDefaultLastRecord = -16 

    Dim wd As Object 
    Dim wdocSource As Object 

    Dim strWorkbookName As String 

    On Error Resume Next 
    Set wd = GetObject(, "Word.Application") 
    If wd Is Nothing Then 
     Set wd = CreateObject("Word.Application") 
    End If 
    On Error GoTo 0 

    Set wdocSource = wd.Documents.Open("R:\Grants\AttachmentBOccupantProtection.docx") 

    strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name 

    wdocSource.MailMerge.MainDocumentType = wdFormLetters 

    wdocSource.MailMerge.OpenDataSource _ 
      Name:=strWorkbookName, _ 
      AddToRecentFiles:=False, _ 
      Revert:=False, _ 
      Format:=wdOpenFormatAuto, _ 
      Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _ 
      sqlstatement:="SELECT * FROM [" & ActiveSheet.Name & "$]" 
    With wdocSource.MailMerge 
     .Destination = wdSendToNewDocument 
     .SuppressBlankLines = True 
     With .DataSource 
      .FirstRecord = wdDefaultFirstRecord 
      .LastRecord = wdDefaultLastRecord 
     End With 
     .Execute Pause:=False 
    End With 

    wd.Visible = True 
    wdocSource.Close SaveChanges:=False 

    Set wdocSource = Nothing 
    Set wd = Nothing 

End Sub 

Answer 1

修改您的過程以接受要打開的文檔的名稱，然後爲需要打開的每個文檔調用一次。此類似：

Sub RunMergeAttachBOccupantProtection(DocName as String) 
    . 
    . 
    . 
    Set wdocSource = wd.Documents.open("R:\Grants\" & DocName & ".docx") 
    . 
    . 
    . 
End Sub 

然後你就可以運行這個快速測試：

Sub TestDriver() 

    Dim MyDoc as String 

    MyDoc = "XX1" 

    if MyDoc = "xx3" or MyDoc = "xx6" then 
    RunMergeAttachBOccupantProtection("xx3") 
    RunMergeAttachBOccupantProtection(MyDoc) 
    Else 
    RunMergeAttachBOccupantProtection(MyDoc) 
    End If 

End Sub