VBA code to excel and word populate

[nmc]

I'm trying to create a VBA code to do this:

Open a dialog box to choose a word file in the path: C:\Add-in\Company A\Templates in docx format

Select as active sheet Navette the file: "Checklist - Navette" if there's no open file with this name appear a message: "ERROR Please push the comand checklist first" and quit the macro

Populate all the bookmarks of the word file with content cells that have name equal as the bookmarks (use sheet Navette)

If the Navette sheet has a cell named "Civilité" and the content is equal to "Female" must go to the excel file in the path: C:\Add-in\Mapping.xlsx on the Replace sheet and search all the words in the column A throught the word file and replace with words in the column B otherwise replace with the words in the column C

Open a dialog box to input the path to save the word with the name TEST in word and pdf format

Close the initial files without saving

Quit all aplications

I'm stucked in the code and it's even working. When I try to run It also get stucked

[Sub TestProcess()

'Initial process
    Dim fd As FileDialog
    Dim strFile As String
    Dim wdDoc As Document
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    Dim SaveAsFileName As String
    Dim SaveAsFileFormat As Integer
    
'Dialog box to pickup the docx file
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .InitialFileName = "C:\Add-in\Company\Templates"
        .Filters.Add "Word Files", "*.docx", 1
        If .Show = -1 Then
            strFile = .SelectedItems(1)
        End If
    End With
    
    Set wdDoc = Documents.Open(strFile)
    
'Identify the checklist
    On Error Resume Next
    Set wb = Workbooks("Company - Navette.xlsx")
    On Error GoTo 0

'Handling with errors
    If wb Is Nothing Then
        MsgBox "ERROR 'Please select the command *Open Navette*first"
        wdDoc.Close
        Set wdDoc = Nothing
        Exit Sub
    End If

'Active Worksheet
    On Error Resume Next
    Set ws = wb.Sheets("Navette")
    On Error GoTo 0
    
'Handling with errors
    If ws Is Nothing Then
        MsgBox "Sheet 'Navette' not found in the workbook."
      
 'For each Bookmark equal name cell replace with the content
 
 For Each wdBookmark In wdDoc.Bookmarks
        wdBookmark.Range.Text = ws.Range(wdBookmark.Name).Value
    Next


'Save file
'Open a dialog box to input the path to save the Word file
SaveAsFileName = Application.GetSaveAsFilename(FileFilter:="Word Files (*.docx), .docx; PDF Files (.pdf), *.pdf", Title:="Save As", InitialFileName:=strFile)

'Check if a file name and format are selected
If SaveAsFileName <> "False" Then
'Determine the selected file format
If Right(SaveAsFileName, 4) = ".pdf" Then
SaveAsFileFormat = 17
Else
SaveAsFileFormat = 0
End If
'Save the file in the selected format
objDoc.SaveAs SaveAsFileName, FileFormat:=SaveAsFileFormat
End If
        
'Close Doc & Excel
        wdDoc.Close
        wb.Close
        
'Reset the documents
        Set wdDoc = Nothing
        Set wb = Nothing
        Exit Sub
    End If
    
End Sub


excelvbams-word
Share
Edit
Delete]

 

[rakesh seebaruth]

Sub rakesh02012023()

'Declare variables
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdRng As Word.Range
Dim xlApp As Excel.Application
Dim xlWkb As Excel.Workbook
Dim xlWks As Excel.Worksheet
Dim ReplaceFilePath As String
Dim ReplaceSheet As String
Dim ReplaceWords As Variant
Dim ReplaceWith As Variant
Dim FilePath As String
Dim BookmarkName As String

'Open a dialog box to choose a word file in the path
FilePath = Application.GetOpenFilename("Word Files (*.docx),*.docx", _
                                        , "Choose a Word file", , False)

If FilePath = "False" Then
    Exit Sub
End If

'Select the "Checklist - Navette" sheet
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then
    Set wdApp = New Word.Application
End If
Set wdDoc = wdApp.Documents(FilePath)
On Error GoTo 0
If wdDoc Is Nothing Then
    MsgBox "ERROR Please push the comand checklist first", vbCritical
    wdApp.Quit
    Set wdApp = Nothing
    Exit Sub
End If

 
For Each wdRng In wdDoc.Bookmarks
    BookmarkName = wdRng.Name
    wdRng.Range.Text = ThisWorkbook.Sheets("Navette").Range(BookmarkName).Value
Next wdRng


ReplaceFilePath = "C:\Add-in\Mapping.xlsx"

'Open the mapping file and select the Replace sheet
Set xlApp = New Excel.Application
Set xlWkb = xlApp.Workbooks.Open(ReplaceFilePath)
Set xlWks = xlWkb.Sheets("Replace")

'Get the replace words and replace with values
ReplaceWords = xlWks.Range("A2", xlWks.Range("A" & xlWks.Rows.Count).End(xlUp)).Value
ReplaceWith = xlWks.Range("B2", xlWks.Range("B" & xlWks.Rows.Count).End(xlUp)).Value

'Check the value of the "Civilité" cell and use the appropriate replace with values
If ThisWorkbook.Sheets("Navette").Range("Civilité").Value = "Female" Then
    wdDoc.Range.Replace What:=ReplaceWords, Replacement:=ReplaceWith, LookAt:=wdWholeWord, _
                        MatchCase:=True, MatchByte:=True, SearchFormat:=False, ReplaceFormat:=False
Else
    ReplaceWith = xlWks.Range("C2", xlWks.Range("C" & xlWks.Rows.Count).End(xlUp)).Value
    wdDoc.Range.Replace What:=ReplaceWords,
    wdDoc.Range.Replace What:=ReplaceWords, Replacement:=ReplaceWith, LookAt:=wdWholeWord, _
                        MatchCase:=True, MatchByte:=True, SearchFormat:=False, ReplaceFormat:=False
End If

'Close the mapping file without saving
xlWkb.Close False
xlApp.Quit

'Open a dialog box to input the path to save the word with the name TEST
FilePath = Application.GetSaveAsFilename("TEST.docx", "Word Files (*.docx),*.docx", _
                                          , "Choose a location to save the file", , False)

If FilePath = "False" Then
    Exit Sub
End If

'Save the word file and close it
wdDoc.SaveAs FilePath
wdDoc.Close

'Save the word file as a pdf and close it
FilePath = Replace(FilePath, ".docx", ".pdf")
wdDoc.SaveAs2 FilePath, wdFormatPDF
wdDoc.Close

'Close Word application without saving
wdApp.Quit False

'Quit all applications
Application.Quit

End Sub

 

[nmc]

This line is giving me error can you help me?