This below code will help to Excel data to word file:
Sub GenerateWordFiles()
'Declare Word application and document objects
Dim wdApp As Object 'Word application instance
Dim wdDoc As Object 'Word document instance
'Paths for template, output folder, and 2nd workbook
Dim TemplatePath As String
Dim SavePath As String
Dim Macro2Path As String
'Excel variables
Dim lastRow As Long, i As Long
Dim contract_keys As String, contract_name As String
'Word Table variables
Dim tbl1 As Object, tbl2 As Object
Dim wb2 As Workbook
Dim wsCP As Worksheet 'Connected Parties sheet
Dim CP_LastRow As Long 'Last row of CP output
Dim CP_Row As Long 'Loop counter
Dim tbl1_Row As Long, tbl2_Row As Long
'Read paths from RUNNNN sheet
''Change below ThisWorkbook.Sheets("RUNNNN") with your Workbook1 sheet name
'''Change H2,J3,J4 to your path addresses
Set wb1 = ThisWorkbook.Sheets("RUNNNN")
TemplatePath = wb1.Range("J4").Value 'Word template
SavePath = wb1.Range("J3").Value 'Output folder
Macro2Path = wb1.Range("J2").Value '2nd workbook file path
startNum = wb1.Range("J1").Value
'Create output folder if not exists
If Dir(SavePath, vbDirectory) = "" Then MkDir SavePath
'Get last row in column A
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
'Create Word application
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True 'Show Word
'Open the second workbook containing the macro
Set wb2 = Workbooks.Open(Macro2Path)
'Loop through input rows starting from value in RUNNNN J1
For i = startNum To lastRow
'Read contract values
contract_keys = wb1.Cells(i, "A").Value
contract_name = wb1.Cells(i, "B").Value
'Send contract key into wb2
''Change sheet name where it want to place the contract_keys, mention that sheet name
''If you want to place it in multiple places, copy the same below line code extra and
''change the sheet name and range below.
wb2.Sheets("Sheet1").Range("D2").Value = contract_keys
'Run macro in second workbook
Application.Run "'" & wb2.Name & "'!PopulateAndSortCPsDetails"
'Set reference to CP output sheet after macro runs
''If the output needs to pull from different sheet then change the name below
''If the output wants to pull from multiple sheet replace the same line
''again below with different Set Variable
Set wsCP = wb2.Sheets("Connected Parties Check")
'Open the Word template for this contract
Set wdDoc = wdApp.Documents.Open(TemplatePath)
'Replace the tag with contract name
ReplaceTag wdDoc, "<<Contract_Name>>", contract_name
'------------------ TABLE PROCESSING BEGINS ----------------------------
'Get references to Table 1 and Table 2
Set tbl1 = wdDoc.Tables(1)
Set tbl2 = wdDoc.Tables(2)
'Find last row of data from A11 downward
CP_LastRow = wsCP.Cells(wsCP.Rows.Count, "A").End(xlUp).Row
'-----------------------------------------------------
' TABLE 1 ? Insert/Delete rows based on CP output
'-----------------------------------------------------
'Ensure table has correct number of rows
AdjustWordTableRows tbl1, CP_LastRow - 10 'Subtract 10 because data starts at row 11
'Fill Table 1 rows
tbl1_Row = 2 'Assuming row 1 is header
For CP_Row = 11 To CP_LastRow
tbl1.Cell(tbl1_Row, 1).Range.Text = wsCP.Cells(CP_Row, "F").Value
tbl1_Row = tbl1_Row + 1
Next CP_Row
'-----------------------------------------------------
' TABLE 2 ? Only authorised rows (Column M)
'-----------------------------------------------------
'Clear all existing data rows in Table 2 (except header)
AdjustWordTableRows tbl2, 0
tbl2_Row = 2
For CP_Row = 11 To CP_LastRow
If wsCP.Cells(CP_Row, "M").Value = "Authorised" Then
'Add new row in Table 2
tbl2.Rows.Add
'Write Column L value into Table 2
tbl2.Cell(tbl2_Row, 1).Range.Text = wsCP.Cells(CP_Row, "L").Value
tbl2_Row = tbl2_Row + 1
End If
Next CP_Row
'------------------ TABLE PROCESSING ENDS ----------------------------
'Construct file name
''Here contract_name will be your output extra sub folder will create
Dim FileName As String
FileName = SavePath & "\" & contract_name
'Create subfolder if missing
If Dir(FileName, vbDirectory) = "" Then MkDir FileName
'Final file path
''File name will pick first 2 characters
FileName = FileName & "\CDD_" & Left(contract_name, 2) & ".docx"
'Delete existing file if already exists
If Dir(FileName) <> "" Then Kill FileName
'Save Word file
wdDoc.SaveAs2 FileName
'Close Word file
wdDoc.Close False
Next i
'Quit Word application
wdApp.Quit
MsgBox "All Word files generated successfully!", vbInformation
End Sub
Sub ReplaceTag(doc As Object, findText As String, replaceText As String)
With doc.Content.Find
.Text = findText
.Replacement.Text = replaceText
.Forward = True
.Wrap = 1
.Execute Replace:=2
End With
End Sub
Sub AdjustWordTableRows(tbl As Object, requiredRows As Long)
Dim currentRows As Long
currentRows = tbl.Rows.Count - 1 'Minus header
'Add missing rows
While currentRows < requiredRows
tbl.Rows.Add
currentRows = currentRows + 1
Wend
'Remove extra rows
While currentRows > requiredRows And requiredRows >= 0
tbl.Rows(tbl.Rows.Count).Delete
currentRows = currentRows - 1
Wend
End Sub
Sub CleanWordTableEmptyRows(tbl As Object)
Dim r As Long
For r = tbl.Rows.Count To 2 Step -1 'Skip header row
If Trim(tbl.Cell(r, 1).Range.Text) = "" Or _
Trim(Replace(tbl.Cell(r, 1).Range.Text, Chr(13), "")) = "" Then
tbl.Rows(r).Delete
End If
Next r
End Sub
