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
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
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
My current loop does loop through the document and copy text, but I have sentence headers and pictures that are missing.
