Excel to Word

Code:

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