Copy from one word document to a template

Question

My current loop does loop through the document and copy text, but I have sentence headers and pictures that are missing.

Dim contentToInsert As String
        contentToInsert = ""

        For Each para In originalDoc.Paragraphs
            If Trim(para.Range.Text) <> "" Then ' Skip empty paragraphs
                contentToInsert = contentToInsert & para.Range.Text & vbCrLf ' Add paragraph text with line breaks
            End If
        Next para

rest of code

Sub ProcessDocumentsWithExcelData()
       Dim excelApp As Object
       Dim excelWorkbook As Object
       Dim docName As String
       Dim convertedDir As String
       Dim templatePath As String
       Dim filePath As String
       Dim WordApp As Object
       Dim originalDoc As Object
       Dim templateDoc As Object
       Dim targetTable As Object
       Dim para As Object

    ' Open Excel file and read cell A2
    On Error Resume Next
    Set excelApp = CreateObject("Excel.Application")
    On Error GoTo 0

    If excelApp Is Nothing Then
        MsgBox "Microsoft Excel is not installed or not available."
        Exit Sub
    End If

    excelApp.Visible = False
    Set excelWorkbook = excelApp.Workbooks.Open("I:\\Work\\Process_Doc_Flow\\Workflows Priority List Tom.xlsx")
    docName = excelWorkbook.Sheets(1).Range("A2").Value & ".docx"
    excelWorkbook.Close False
    excelApp.Quit
    Set excelWorkbook = Nothing
    Set excelApp = Nothing

    If docName = ".docx" Then
        MsgBox "No document name found in cell A2."
        Exit Sub
    End If

    ' Set the directory paths
    convertedDir = "I:\\Work\\Process_Doc_Flow\\ConvertedDocFiles\\"
    templatePath = "I:\\Work\\Process_Doc_Flow\\Workflow Template MyAvatar Blank.docx"

    ' Initialize Word Application
    On Error Resume Next
    Set WordApp = CreateObject("Word.Application")
    On Error GoTo 0

    If WordApp Is Nothing Then
        MsgBox "Microsoft Word is not installed or not available."
        Exit Sub
    End If

    WordApp.Visible = True ' Ensure Word application is visible

    ' Check for the specific document in the ConvertedDocFiles directory
    filePath = convertedDir & docName
    If Dir(filePath) = "" Then
        MsgBox "The document " & docName & " was not found in the directory."
        WordApp.Quit
        Set WordApp = Nothing
        Exit Sub
    End If

    ' Open the original document
    Set originalDoc = WordApp.Documents.Open(filePath, Visible:=True)

    ' Open the template
    Set templateDoc = WordApp.Documents.Open(templatePath, Visible:=True)

    ' Find the table containing "List of core functions provided by the component"
    Dim searchRange As Object
    Set searchRange = templateDoc.Content
    searchRange.Find.ClearFormatting
    searchRange.Find.Text = "List of core functions provided by the component"


   If searchRange.Find.Execute Then
        ' Identify the table containing the found text
        Set targetTable = searchRange.Tables(1)

        ' Find the exact cell to insert content (next column after the found text)
        Dim rowIndex As Integer
        rowIndex = searchRange.Information(wdStartOfRangeRowNumber)

        Dim targetCell As Object
        Set targetCell = targetTable.Cell(rowIndex, 2) ' Use the rowIndex to find the correct row

       
        ' Loop through each paragraph in the original document and paste it into the target cell
        Dim contentText As String
        contentText = "" ' Initialize the content to add

        ' Clear any existing content in the target cell
        targetCell.Range.Text = ""

        ' Accumulate the content from all paragraphs in the original document
        'works but does not copy formatting or pictures
        Dim contentToInsert As String
        contentToInsert = ""

        For Each para In originalDoc.Paragraphs
            If Trim(para.Range.Text) <> "" Then ' Skip empty paragraphs
                contentToInsert = contentToInsert & para.Range.Text & vbCrLf ' Add paragraph text with line breaks
            End If
        Next para

        Stop

        ' Safely set the content of the target cell in one operation
        With targetCell.Range
            .Text = contentToInsert ' Replace the cell's content with the accumulated text
        End With


        Debug.Print "Inserted content from " & filePath & " into the table at the specified location."
    Else
        MsgBox "The specified text 'List of core functions provided by the component' was not found in the template."
    End If
    ' Save the updated template document
    templateDoc.Save

    ' Close documents
    originalDoc.Close False
    templateDoc.Close False

    ' Quit Word Application
    WordApp.Quit
    Set WordApp = Nothing

    MsgBox "The document " & docName & " has been processed and updated in the template."
End Sub

Answer 1

Here's a very basic example of taking the content from one document and inserting it into a table cell in another:

Sub TransferTester()

    Dim docSrc As Document, docDest As Document
    
    Set docSrc = Documents("Document1") 'source document
    Set docDest = ThisDocument          'destination document
    
    docDest.Tables(1).Cell(1, 1).Range.FormattedText = docSrc.Content.FormattedText

End Sub

Example: