Почему значения в ячейках (Excel) не заменяют переменные в файлах Words?

Question

Я создал файл Excel, который пользователь должен заполнить в одном столбце, после того, как он закончит, он нажимает кнопку, генерирующую три файла Word. В Excel я назвал ячейки, в которые были записаны данные пользователя. в файлах слов я поместил переменные (имена ячеек), где я хотел. все хорошо работает, кроме замены деталей, которые пользователь вводит в переменные в файлах слов.

Sub createPDF()
Application.ScreenUpdating = False
Dim objWord As Object
Dim ws As Worksheet
Dim theString As String
Dim TemplatePath As String
Dim xWb As Workbook
Dim Pscope As String
'ws.Activate
Set ws = ThisWorkbook.ActiveSheet
Set objWord = CreateObject("Word.Application")
Set xWb = Application.ThisWorkbook
TemplatePath = xWb.Path
objWord.Visible = True

'Target File Extension (must include wildcard "*")
  myExtension = "*.doc*"

'Target Path with Ending Extention
  myfile = Dir(TemplatePath + "\Template" & "\" & myExtension)

'Loop through each word file in folder
Do While myfile <> ""
objWord.Documents.Open TemplatePath + "\Template" & "\" & myfile 'TemplatePath + "\ProposalTemplate.dotm" ' change as required



With objWord.ActiveDocument.Content.Find

.Text = "company_ename"
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("company_ename").Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll


.Text = "owner_fname1"
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("owner_fname1").Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll

.Text = "owner_pname1"
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("owner_pname1").Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll

.Text = "owner_fullname1"
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("owner_fullname1").Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll

.Text = "owner_id1"
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("owner_id1").Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll

.Text = "owner_allotted1"
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("owner_allotted1").Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll


For i = 2 To 4
.Text = "owner_fname" & CStr(i)
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("owner_fname" & CStr(i)).Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll

.Text = "owner_pname" & CStr(i)
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("owner_pname" & CStr(i)).Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll

.Text = "owner_fullname" & CStr(i)
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("owner_fullname" & CStr(i)).Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll

.Text = "owner_id" & CStr(i)
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("owner_id" & CStr(i)).Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll

.Text = "owner_allotted" & CStr(i)
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("owner_allotted" & CStr(i)).Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll


Next i

.Text = "house"
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("house").Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll

.Text = "director_pname1"
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("director_pname1").Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll

.Text = "director_fname1"
.MatchCase = False
.MatchWholeWord = True
.replacement.Text = ws.Range("director_fname1").Value
.wrap = wdfindcontinue
.Execute Replace:=wdReplaceAll


End With

Dim TheFileName As String
        TheFileName = TemplatePath + "\Output\" + ws.Range("company_ename").Value + "_" + Replace(myfile, "docx", "") + ".docx"

        '(SaveAs is for Office 2003 and earlier - deprecated)
        objWord.ActiveDocument.SaveAs TheFileName
            'replaces existing .doc iff exists


        ' Close Documents and Quit Word
        objWord.ActiveDocument.Close savechanges:=False
       ' objWord.ActiveDocument.Close 'close .DOCx
 myfile = Dir
Loop
Set objWord = Nothing

MsgBox "Generation Complete!"
Application.ScreenUpdating = True
End Sub

Answer 1

У вас много повторяющихся кодов, которые должны быть в отдельной подпрограмме.

Например:

Sub createPDF()

    Dim objWord As Object, doc As Object
    Dim ws As Worksheet
    Dim theString As String
    Dim TheFileName As String, nm, i As Long
    Dim TemplatePath As String, myExtension, myfile
    Dim Pscope As String

    Set ws = ThisWorkbook.ActiveSheet
    TemplatePath = ThisWorkbook.Path

    Set objWord = CreateObject("Word.Application")
    objWord.Visible = True

    myExtension = "*.doc*"
    myfile = Dir(TemplatePath + "\Template" & "\" & myExtension)

    Do While myfile <> ""
        Set doc = objWord.Documents.Open(TemplatePath + "\Template" & "\" & myfile)
        For Each nm In Array("company_ename", "owner_fname1", "owner_pname1", _
                             "owner_fullname1", "owner_id1", "owner_allotted1", _
                             "house", "director_pname1", "director_fname1")
            DoReplace doc, ws, nm
        Next nm

        For i = 2 To 4
            For Each nm In Array("owner_fname", "owner_pname", "owner_fullname", _
                                    "owner_id", "owner_allotted")
                DoReplace doc, ws, nm & CStr(i)
            Next nm
        Next i

        TheFileName = TemplatePath & "\Output\" & ws.Range("company_ename").Value & _
                      "_" & Replace(myfile, "docx", "") & ".docx"

        doc.SaveAs TheFileName
        doc.Close savechanges:=False

        myfile = Dir
    Loop
    Set objWord = Nothing

    MsgBox "Generation Complete!"

End Sub

Sub DoReplace(doc As Object, ws As Worksheet, txt)
    With doc.Content.Find
        .Text = "{" & txt & "}" 'in the Word doc the tag is enclosed in{}
        .MatchCase = False
        .MatchWholeWord = True
        .replacement.Text = ws.Range(txt).Value
        .wrap = 1 'wdfindcontinue
        .Execute Replace:=2 'wdReplaceAll
    End With
End Sub