OK try my code first. You see so far, if this is satisfactory for you?
Sub CreateDocuments()
' Define the workbook and worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Dim wsMailMerge As Worksheet: Set wsMailMerge = wb.Sheets("MailMerge")
Dim wsMappings As Worksheet: Set wsMappings = wb.Sheets("Mappings")
Rem test to temply comment out
Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.DisplayAlerts = False
' Define the last row in the sheet
Dim LastRow As Long
LastRow = wsMailMerge.Cells(wsMailMerge.Rows.count, 1).End(xlUp).Row
Dim WordApp As Object, myDoc As Object, wdRng As Object, TableHeader As String, placeholders As Object, tblREPEAT As Object
Dim tbl As Object 'Word.Table
Dim Find1 As Excel.Range, Find2 As Excel.Range, Find3 As Excel.Range, header As String
Dim Timer2 As Single
' Open the Word application
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
Rem test to temply comment out
WordApp.ScreenUpdating = False
' Define a Dictionary to store which investors have been processed
Dim ProcessedInvestors As Object
Set ProcessedInvestors = CreateObject("Scripting.Dictionary")
Set placeholders = CreateObject("Scripting.Dictionary")
' Loop through each row in the MailMerge sheet
Dim r As Long
For r = 2 To LastRow ' Assuming your data starts from row 2 (row 1 contains headers)
' Get the name of the current investor
Dim InvestorName As String
InvestorName = wsMailMerge.Cells(r, 1).value ' Assuming column A contains the investor names
' Check if the investor has already been processed
If Not ProcessedInvestors.Exists(InvestorName) Then
' Mark the investor as processed
ProcessedInvestors.Add InvestorName, True
' Open the Word document
Set myDoc = WordApp.Documents.Open(wb.Path & "\sample2 - Template SOA - Copy.docx") ' Use the workbook's path and the name of your Word template
Rem get the Table include `REPEAT`
For Each tbl In myDoc.Tables
If InStr(tbl.Cell(2, 1).Range.Text, "REPEAT") > 0 Then
Rem back up Placeholders in a row of the table
Rem use the clipboard, whilst the system needs the clipboard, causes a problem
' tbl.Rows(2).Range.Copy
' myDoc.Range(tbl.Cell(tbl.Rows.count, 1).Range.Start, tbl.Cell(tbl.Rows.count, 1).Range.Start).Paste
Rem implement without the clipboard
myDoc.Range(tbl.Cell(tbl.Rows.count, 1).Range.Start, tbl.Cell(tbl.Rows.count, 1).Range.Start).FormattedText = tbl.Rows(2).Range.FormattedText
Rem clear the `REPEAT"TableDisplay2"` in the backup row
Set wdRng = myDoc.Range(tbl.Cell(3, 1).Range.Start, tbl.Cell(3, 1).Range.Start)
wdRng.MoveUntil "{"
wdRng.Start = tbl.Cell(3, 1).Range.Start
wdRng.Text = vbNullString
Set tblREPEAT = tbl 'Store tables with variable tblREPEAT
'Exit For ' if only one table include `REPEAT`
End If
Next tbl
' Loop through each column in the row
Dim c As Long
Dim clumCount_wsMailMerge As Long: clumCount_wsMailMerge = wsMailMerge.Cells(r, Columns.count).End(xlToLeft).Column
'For c = 1 To wsMailMerge.Cells(r, Columns.count).End(xlToLeft).Column
For c = 1 To clumCount_wsMailMerge
' If c = 176 Then Stop ' just for check
Rem Your placeholder and the header of the wsMailMerge is NOT case-sensitive!!
' Define the placeholder and the value to replace it with
Dim placeholder 'As String
placeholder = "{{" & Trim(wsMailMerge.Cells(1, c).value) & "}}" ' The placeholder is the header in the Mappings sheet
'placeholder = "{{" & Trim(wsMailMerge.Cells(1, c).Formula) & "}}" ' The placeholder is the header in the Mappings sheet
'If placeholder = "{{Notes47}}" Then Stop 'just for check
' If placeholder = "{{Address4}}" Then Stop 'just for check
Dim value As String
value = wsMailMerge.Cells(r, c).value ' The value is the cell value in the current row
'If Trim(wsMailMerge.Cells(1, c).value) = "SOADate" Then Stop
' Check for special formatting instructions
Dim formatting As String
GoSub getFormat
'If placeholder Like "*{{SOADate}}*" Then Stop
' If value = vbNullString Then Stop 'just for test
Set wdRng = myDoc.Content
' Replace the placeholders in the Word document with the values from the record
'With myDoc.Content.Find
With wdRng.Find
.Text = placeholder
'.Replacement.Text = value
.Wrap = wdFindContinue
.MatchWholeWord = True
'.Execute Replace:=wdReplaceAll
Do While .Execute()
Rem don't do this in the record rows of the table including `REPEAT"TableDisplay2"` this time
If .Found Then
If .Parent.InRange(myDoc.Range(tblREPEAT.Cell(2, 1).Range.Start, tblREPEAT.Cell(3, tblREPEAT.Columns.count).Range.End)) Then
Exit Do
Else
.Parent.Text = value 'ie. .Replacement.Text = value and preserve the format
End If
End If
Loop
End With
NextPlaceholder:
Next c
''''''''''''''''''''''''''''''''''''''''''''''''''''''
Timer2 = Timer()
' Loop through each table
'Dim tbl As Table
'Dim tbl As Object 'Word.Table
For Each tbl In myDoc.Tables
If InStr(tbl.Cell(2, 1).Range.Text, "REPEAT") > 0 Then
'If tbl Is tblREPEAT Then
'If tbl.Range.Start = tblREPEAT.Range.Start Then
' Initialize row counter
Dim rowCounter As Integer
rowCounter = 1
Rem must be without merged cells by this way
' Loop through each row
'Dim rw As Object 'Word.Row
'For Each rw In tbl.Rows
' Loop through each cell
Dim cel As Object 'Word.Cell
'For Each cel In rw.Cells
For Each cel In tbl.Range.Cells
' Check if the cell contains "REPEAT"
If InStr(cel.Range.Text, "REPEAT") > 0 Then
' Extract the "TableDisplayX" placeholder
Dim startPos As Integer
startPos = InStr(cel.Range.Text, "TableDisplay")
If startPos > 0 Then
Rem if length of `X` is longer then 1 then this will be wrong
'TableHeader = Mid(cel.Range.Text, startPos, 13) ' There are 13 characters in "TableDisplayX"
TableHeader = Mid(cel.Range.Text, startPos, InStr(startPos, cel.Range.Text, ChrW(8221)) - startPos) ' There are 13 characters in "TableDisplayX"
Rem clear the `REPEAT"TableDisplay2"`
Set wdRng = myDoc.Range(cel.Range.Start + startPos, cel.Range.Start + startPos)
wdRng.MoveUntil ChrW(8221)
wdRng.Start = cel.Range.Start
wdRng.End = wdRng.End + 1
wdRng.Text = vbNullString
Else
MsgBox "TableDisplay column not found", vbCritical
Rem don't forget to restore
'Exit Sub
GoTo ExitSub
End If
Set Find2 = wsMailMerge.Range("1:1").Find(TableHeader, lookat:=xlWhole, LookIn:=xlFormulas)
' Determine the number of 'y' values in the "TableDisplayX" column for the current investor
'Dim TableDisplayColumn As Range
Dim TableDisplayColumn As Excel.Range
'Set TableDisplayColumn = wsMailMerge.Range(Cells(2, Find2.Column), Cells(LastRow, Find2.Column)) ' Replace "TableDisplayX" with the actual column letter
Set TableDisplayColumn = wsMailMerge.Range(wsMailMerge.Cells(2, Find2.Column), wsMailMerge.Cells(LastRow, Find2.Column)) ' Replace "TableDisplayX" with the actual column letter
Dim FolioColumn As Range
Set FolioColumn = wsMailMerge.Range("A2:A" & LastRow)
Dim count As Integer
count = Application.WorksheetFunction.CountIfs(TableDisplayColumn, "y", FolioColumn, InvestorName)
' tbl.Cell(tbl.Rows.count, 1).Split NumColumns:=2
' tbl.Cell(tbl.Rows.count, 1).Width = tbl.Cell(tbl.Rows.count - 1, 1).Width
' tbl.Cell(tbl.Rows.count, 2).Width = tbl.Cell(tbl.Rows.count - 1, 2).Width
If count > 1 Then
'tbl.Rows(tbl.Rows.count - 1).Range.Copy
' Insert (n-1) rows below the repeating row
Dim i As Integer
For i = 1 To count - 1 - 1
'rw.Range.Rows.Add
'myDoc.Range(tbl.Cell(3, 1).Range.Start, tbl.Cell(3, 1).Range.Start).Paste
'tbl.Rows.Add tbl.Rows(tbl.Rows.count)
Rem add new rows like the backup one
myDoc.Range(tbl.Cell(tbl.Rows.count, 1).Range.Start, tbl.Cell(tbl.Rows.count, 1).Range.Start).FormattedText = tbl.Rows(3).Range.FormattedText
Next i
'just for test
' tbl.Range.Document.Tables.Add tbl.Range.Document.Range(tbl.Cell(tbl.Rows.count, 1).Range.Start, tbl.Cell(tbl.Rows.count, 1).Range.Start), count - 1, tbl.Columns.count
' tbl.Cell(tbl.Rows.count, 1).Merge tbl.Cell(tbl.Rows.count, 2)
' Populate the cells in the new table
'Dim newRow As Row
Dim newCell As Word.Cell
Dim rowIndex As Integer
Dim firstRow As Long
firstRow = GetFirstRowWithY(TableDisplayColumn, FolioColumn, InvestorName)
rowIndex = 0
'For Each newRow In tbl.Range.Rows
'If rowCounter = count Then
'For Each newCell In newRow.Range.Cells
rowCounter = 0
Rem `myDoc.Range(...).Cells` get the range of new cells
For Each newCell In myDoc.Range(tbl.Range.Cells(6 + 1).Range.Start, tbl.Cell(count + 1, tbl.Columns.count).Range.End).Cells
' Define the placeholder and the value to replace it with
' Dim placeholder As String ' this already declare before
If rowCounter = 0 Then
rowCounter = newCell.rowIndex
ElseIf rowCounter < newCell.rowIndex Then
rowIndex = rowIndex + 1 ' Increment row counter
rowCounter = newCell.rowIndex
End If
If newCell.ColumnIndex = 1 Then
With newCell.Range.Find
.ClearAllFuzzyOptions
.ClearFormatting
.Wrap = wdFindStop
.Forward = True
.MatchWildcards = True 'use Wildcards to find
.Text = "\{\{*\}\}"
Do While .Execute
If .Parent.End > newCell.Range.End Then Exit Do 'if over the range of curent cell then exit
Rem Take note of the placeholder and its Range
'placeholders.Add VBA.Mid(.Parent.Text, 3, VBA.Len(.Parent.Text) - 4), .Parent '3=len("{{")+1
placeholders.Add .Parent.Text, .Parent.Duplicate '3=len("{{")+1
Loop
End With
Else
Rem Take note of the placeholder and its Range
placeholders.Add VBA.Left(newCell.Range.Text, VBA.Len(newCell.Range.Text) - 2), newCell.Range ' The placeholder is the header in the Mappings sheet
End If
'Dim value As String ' Already declared!!
For Each placeholder In placeholders.keys
'Set Find3 = wsMappings.Range("A:A").Find(placeholder, lookat:=xlWhole, LookIn:=xlValues)
Set Find3 = wsMappings.Range("A:A").Find(placeholder, lookat:=xlWhole, LookIn:=xlValues)
If Not Find3 Is Nothing Then
header = Find3.Offset(0, 1).value
'Set Find3 = wsMailMerge.Rows(1).Find(header, lookat:=xlWhole, LookIn:=xlFormulas)
Set Find3 = wsMailMerge.Range("1:1").Find(header, lookat:=xlWhole, LookIn:=xlFormulas)
value = wsMailMerge.Cells(firstRow + rowIndex + 1, Find3.Column).value ' The value is the cell value in the current row
' Replace the placeholders in the Word document with the values from the record
'newCell.Range.Text = value
GoSub getFormat:
placeholders(placeholder).Text = value
End If
Next placeholder
placeholders.RemoveAll
Next newCell
'End If
' rowIndex = rowIndex + 1
'Next newRow
Else
Rem if there is no more row
tbl.Rows(3).Delete 'delete the backup placeholdere copy one
End If
' GoTo currentDocDone: ' if only one table include `REPEAT`
GoTo nextTable
End If
Next cel
' Increment row counter
'rowCounter = rowCounter + 1
'Next rw
' Else
' GoTo nextTable
End If
nextTable:
Next tbl
currentDocDone:
MsgBox "time = " & (Timer() - Timer2)
''''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
' Save the Word document
myDoc.SaveAs wb.Path & "\" & wsMailMerge.Cells(r, 1).value & ".docx" ' Use the workbook's path and the investor's name from column A
Rem temply comment out for test
'myDoc.Close SaveChanges:=False
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "Word doc save error", vbExclamation
End If
End If
Next r
Rem You can not do it here, cause WordApp'll be referred to later
' Close the Word application
' WordApp.Quit
ExitSub:
WordApp.ScreenUpdating = True
Rem temply comment out for test
' Close the Word application
' WordApp.Quit
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.DisplayAlerts = True
Exit Sub
getFormat:
Set Find1 = Nothing
formatting = ""
Set Find1 = wsMappings.Range("A:A").Find(placeholder, lookat:=xlWhole, LookIn:=xlValues)
If Not Find1 Is Nothing Then
formatting = Find1.Offset(0, 2).value
Else
GoTo NextPlaceholder
End If
'If Not IsError(formatting) Then
If formatting <> vbNullString And Not IsError(formatting) And formatting <> "SuperScript" Then
Select Case formatting
Case "MMMM dd, yyyy"
value = Format(value, "MMMM dd, yyyy")
Case "N0"
value = Format(value, "#,##0")
Case "N1"
value = Format(value, "#,##0.0")
Case "N2"
value = Format(value, "#,##0.00")
Case "N3"
value = Format(value, "#,##0.000")
Case "N4"
value = Format(value, "#,##0.0000")
Case "P0"
value = Format(value, "0%")
Case "P1"
value = Format(value, "0.0%")
Case "P2"
value = Format(value, "0.00%")
Case "P3"
value = Format(value, "0.000%")
Case "P4"
value = Format(value, "0.0000%")
Case "NewLine"
If value <> vbNullString Then
'value = value & Chr(10)
value = Chr(10) & value
End If
Case "SuperScript"
' Handle superscript here
End Select
End If
Return
End Sub
Your code and samples still have many problems and unclear points. You can only judge whether this is what you want. I just try to cooperate with the code you wrote to achieve it as much as possible.
It seems that your code and samples are still experiencing some issues and unclear aspects. It's up to you to determine if this is exactly what you are looking for. My goal is to work alongside the code you have written to do my best to achieve the desired outcome. Good luck!
Ps. If I had time I will try to see how to do it in Python.
