Having problems with loop copying an Excel range from diffrent sheets to a Word file using VBA

Question

In the same context to [https://stackoverflow.com/questions/66407797/having-problems-copying-an-excel-range-to-a-word-file-using-vba][1]

As I have been helped, I try to make a loop, as I have the same area on several sheets in a worksheet / book, which I would like to copy via a loop to an existing word document (sheet by sheet), save it as a PDF and move on to the next sheet.

I have tried the following, but get an error: "Run-Time error '462' - the remote server machine does not exist or is unavailable". It's for the code line:

Set myDoc = WordApp.Documents.Open(Filename:=stWordDocument, AddToRecentFiles:=False, Visible:=False) 

Code try "Updated code" from BigBen:

Sub CopyToWordAndPrintPDF()

  'PURPOSE: Copy/Paste An Excel Table Into a New Word Document
  'NOTE: Must have Word Object Library Active in Order to Run _
  (VBE > Tools > References > Microsoft Word 12.0 Object Library)
  'SOURCE: www.TheSpreadsheetGuru.com
  
  'Name of the existing Word document
  Const stWordDocument As String = "C:\Users\SDETHBP\Documents\FCM\FCM Ulvetræning Øvelser\U7-U12\Word Forside\Forside fra Excel test.docx"
  
  'Word objects/declared variables.
  Dim WordApp As Word.Application
  Dim myDoc As Word.Document
  Dim Ws As Worksheet
  Dim myArr As Variant, a As Variant
  Dim rangeArr As Variant
  Dim i As Integer
    
'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False

'Create an Instance of MS Word
  On Error Resume Next
    
    'Is MS Word already opened?
      Set WordApp = GetObject(class:="Word.Application")
    
    'Clear the error between errors
      Err.Clear

    'If MS Word is not already open then open MS Word
      If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")
    
    'Handle if the Word Application is not found
      If Err.Number = 429 Then
        MsgBox "Microsoft Word could not be found, aborting."
        GoTo EndRoutine
      End If

  On Error GoTo 0
  
  With WordApp
    'Make MS Word Visible and Active
    WordApp.Visible = False
    
    'Create a loop
    myArr = Array("U7AB1", "U7AB2", "U7BC1")
    rangeArr = "A1:N24"
    
    'Set myDoc = WordApp.Documents.Add
    'Change: [Set myDoc = WordApp.Documents.Add] to:
    Set myDoc = WordApp.Documents.Open(Filename:=stWordDocument, AddToRecentFiles:=False, Visible:=False)
        
    For i = 0 To UBound(myArr)
      Set Ws = Sheets(myArr(i))
      With Ws
  
        'Copy Excel content to word
        ThisWorkbook.Worksheets(myArr(i)).Range(rangeArr).Copy
    
        With Documents(stWordDocument).PageSetup
            .LineNumbering.Active = False
            .TopMargin = CentimetersToPoints(0)
            .BottomMargin = CentimetersToPoints(0)
            .LeftMargin = CentimetersToPoints(0)
            .RightMargin = CentimetersToPoints(0)
        'Paste it to the selected Word template
            With myDoc
                .Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
                .SaveAs2 Filename:=Split(stWordDocument, ".docx")(0) & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
                '.SaveAs2 Filename:=ThisWorkbook.Name & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
                .Close False
            End With
        End With
      End With
    Next
    .Quit
  End With
                  
EndRoutine:
'Optimize Code
  Application.ScreenUpdating = True
  Application.EnableEvents = True

'Clear The Clipboard
  Application.CutCopyMode = False

End Sub

Can someone guide me? so I can get a PDF per. sheet, where it takes the same area, on each sheet, but saves it as independent pdf files, preferably named after the sheet name.pdf. From the same word file, which should not be saved as now, but will be used as it has a watermark, which should go again for all sheets.

[1]: Having problems copying an Excel range to a Word file using VBA

Answer 1

Just to wrap up what is in the comments above:

Sub CopyToWordAndPrintPDF()

   'PURPOSE: Copy/Paste An Excel Table Into a New Word Document
   'NOTE: Must have Word Object Library Active in Order to Run _
    (VBE > Tools > References > Microsoft Word 12.0 Object Library)
   'SOURCE: www.TheSpreadsheetGuru.com
  
   'filepath and word template
   Const filePath As String = "C:\Users\SDETHBP\Documents\FCM\FCM Ulvetræning Øvelser\U7-U12\"
   Const wordTemplate As String = "Word Forside\Forside fra Excel test.dotx"
  
   'Word objects/declared variables.
   Dim WordApp As Word.Application
   Dim myDoc As Word.Document
   Dim Ws As Worksheet
   Dim myArr As Variant, a As Variant
   Dim rangeArr As Variant
   Dim i As Integer
    
   'Optimize Code
   Application.ScreenUpdating = False
   Application.EnableEvents = False

   'Create an Instance of MS Word
   On Error Resume Next
    
   'Is MS Word already opened?
   Set WordApp = GetObject(class:="Word.Application")
    
   'Clear the error between errors
   Err.Clear

   'If MS Word is not already open then open MS Word
   If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")
    
   'Handle if the Word Application is not found
   If Err.Number = 429 Then
      MsgBox "Microsoft Word could not be found, aborting."
      GoTo EndRoutine
   End If

   On Error GoTo 0
  
   With WordApp
      'Make MS Word Visible and Active
      WordApp.Visible = False
    
      'Create a loop
      myArr = Array("U7AB1", "U7AB2", "U7BC1")
      rangeArr = "A1:N24"
        
      For i = 0 To UBound(myArr)
 
         'Copy Excel content to word
         ThisWorkbook.Worksheets(myArr(i)).Range(rangeArr).Copy
    
         Set myDoc = WordApp.Documents.Add(Template:=filePath & wordTemplate, Visible:=False)
         'With Documents(stWordDocument).PageSetup
         With myDoc
            With .PageSetup
               .LineNumbering.Active = False
               .TopMargin = CentimetersToPoints(0)
               .BottomMargin = CentimetersToPoints(0)
               .LeftMargin = CentimetersToPoints(0)
               .RightMargin = CentimetersToPoints(0)
            End With
            'Paste it to the selected Word template
            .Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
            .SaveAs2 Filename:=filePath & myArr(i) & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
            .Close False
         End With
      Next
      .Quit
   End With
                  
EndRoutine:
   'Optimize Code
   Application.ScreenUpdating = True
   Application.EnableEvents = True

   'Clear The Clipboard
   Application.CutCopyMode = False

End Sub