如何使用 excel vba 從行創建多個 word 文檔？

Question

我有一個包含多個個人信息的 excel 工作表。 我需要為每個人填充一個單詞模板。 所有名稱都列在Column A中，每個信息子集Columns B:N中。 我有一個預先制作的模板，其中包含某些文本值，我將用特定列中的數據替換這些值。 我的代碼目前非常適合單個行。 我需要它循環，以便我可以一鍵創建和填寫所有文檔。 我還需要一些幫助來編寫基於“<>”單元格中值 0、1、2 或 3 的代碼部分，將插入一行文本。 我嘗試使用IF公式在 excel 中編寫公式，但我需要輸入的文本行太長。 任何幫助都將不勝感激。

我的代碼如下...

Sub ReplaceText()
Dim wApp As Word.Application
Dim wDoc As Word.Document
Set wApp = CreateObject("Word.Application")
wApp.Visible = True

Set wDoc = wApp.Documents.Open("z:\Sound Sleepers\forms\PCP.dotx")

With wDoc
    .Application.Selection.Find.Text = "<<PCP>>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("D2")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<<name>>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("A2")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<<dob>>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("B2")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<<dos>>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("M2")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<<results>>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("O2")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<<Sleep>>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("L2")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<<Sleep>>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("L2")
    .Application.Selection.EndOf
    

    .SaveAs2 Filename:=("Oneida PCP"), _
    FileFormat:=wdFormatXMLDocument, AddtoRecentFiles:=False
End With

End Sub

Answer 1

這是for循環。 它使用 A 列中的值保存文檔。

Sub ReplaceText()
    Dim wApp As Word.Application
    Dim wDoc As Word.Document
    Set wApp = CreateObject("Word.Application")
    wApp.Visible = True
    
    
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row ' all of column A
    For r = 2 To lastRow  ' each row
        DocName = Range("A" & r).Value
    
        Set wDoc = wApp.Documents.Open("z:\Sound Sleepers\forms\PCP.dotx")
        With wDoc
            .Application.Selection.Find.Text = "<<PCP>>"
            .Application.Selection.Find.Execute
            .Application.Selection = Range("D" & r)
            .Application.Selection.EndOf
            
            .Application.Selection.Find.Text = "<<name>>"
            .Application.Selection.Find.Execute
            .Application.Selection = Range("A" & r)
            .Application.Selection.EndOf
            
            .Application.Selection.Find.Text = "<<dob>>"
            .Application.Selection.Find.Execute
            .Application.Selection = Range("B" & r)
            .Application.Selection.EndOf
            
            .Application.Selection.Find.Text = "<<dos>>"
            .Application.Selection.Find.Execute
            .Application.Selection = Range("M" & r)
            .Application.Selection.EndOf
            
            .Application.Selection.Find.Text = "<<results>>"
            .Application.Selection.Find.Execute
            .Application.Selection = Range("O" & r)
            .Application.Selection.EndOf
            
            .Application.Selection.Find.Text = "<<Sleep>>"
            .Application.Selection.Find.Execute
            .Application.Selection = Range("L" & r)
            .Application.Selection.EndOf
            
            .Application.Selection.Find.Text = "<<Sleep>>"
            .Application.Selection.Find.Execute
            .Application.Selection = Range("L" & r)
            .Application.Selection.EndOf
            
            NormalCheck = Range("O" & r).Value
            Phrase = "Invalid Normal Check"
            Select Case NormalCheck 
              Case 0 
                Phrase = "Normal"
              Case 1 
                Phrase = "Abnormal Questionnaire, Normal ESS" 
              Case 2 
                Phrase = "Normal Questionnaire, Abnormal ESS" 
              Case 3 
                Phrase = "Abnormal Questionnaire, Abnormal ESS" 
              Case Else 
                Phrase = "Invalid Normal Check" 
            End Select 
            
            .Application.Selection.Find.Text = "<<NormalCheck>>"
            .Application.Selection.Find.Execute
            .Application.Selection = Phrase
            .Application.Selection.EndOf
               
            .SaveAs2 Filename:=(DocName), _
            FileFormat:=wdFormatXMLDocument, AddtoRecentFiles:=False
        End With
    Next

End Sub