Insert adjustable table in Word document from Excel - excel

Question

I will have two situations either:
Otherwise the first cell, will contain more values separated by ";" as follows:
These situations should result in different tables which should be inserted in a pre-existing Word document I open with the VBA from Excel.
The resulting tables are shown below:
I just inserted a "fixed" table in the Word document and replace the inside values, this isn't sufficient anymore.
This is the code I use to open a Word document and replace certain words and save the newly made Word documents as a new file in both docx and pdf format:
Sub Sample()
Const wdFindContinue As Long = 1
Const wdReplaceAll As Long = 2
Const StrNoChr As String = """*./\:?|"
Dim oWordApp As Object, oWordDoc As Object, rngStory As Object
Dim sFolder As String, strFilePattern As String
Dim strFileName As String, sFileName As String
Dim cant As Integer
Dim tex As String
Dim max As Integer
Dim total As Integer
Dim final As Integer
sFolder = "C:\Users\name\folder\"
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = False
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Data")
last_row = Application.WorksheetFunction.CountA(sh.Range("A:A"))
For i = 2 To last_row
sFileName = sFolder & "wordfile.docx"
Set oWordDoc = oWordApp.Documents.Open(sFileName)
For Each rngStory In oWordDoc.StoryRanges
With rngStory.Find
If sh.Range("C" & i).Value <> "" Then
.Text = "_Name1"
.Replacement.Text = sh.Range("C" & i).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End If
If sh.Range("D" & i).Value <> "" Then
.Text = "_Name2"
.Replacement.Text = sh.Range("D" & i).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End If
End With
Next
StrName = Sheets(1).Cells(i, 2)
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next j
StrName = Trim(StrName)
With oWordDoc
.SaveAs Filename:=sFolder & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
'.SaveAs Filename:=sFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.ExportAsFixedFormat sFolder & StrName & ".pdf", 17
.Close SaveChanges:=False
End With
Next i
oWordApp.Quit
Set oWordDoc = Nothing
Set oWordApp = Nothing
MsgBox "Succes"
End Sub
The code isn't relevant for the specific problem, but may give some inspiration or other ideas.
EDIT:
I tried with this:
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=2, NumColumns:= 4
As suggested by MacroPod, but it doesn't work.

Answer 1

For example, assuming the basic tables are already there and you have code to populate the rows with the pre-processed data:
Sub Demo()
Dim oWdApp As Object, oWdDoc As Object, oWdRng As Object, oWdTbl As Object
Dim sFolder As String, sFileName As String, StrTxt As String
Dim last_row As Long, r As Long, c As Long, i As Long, j As Long
Const wdFindContinue As Long = 1: Const wdReplaceAll As Long = 2
Const wdFormatXMLDocument As Long = 12: Const wdFormatPDF As Long = 17
Const StrNoChr As String = """*./\:?|"
sFolder = "C:\Users\name\folder\"
Dim sh As Worksheet: Set sh = ThisWorkbook.Sheets("Data")
last_row = Application.WorksheetFunction.CountA(sh.Range("A:A"))
On Error Resume Next
Set oWdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set oWdApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
oWdApp.Visible = False
For i = 2 To last_row
sFileName = sFolder & "wordfile.docx"
Set oWdDoc = oWdApp.Documents.Add(sFileName)
With oWdDoc
For Each oWdRng In .StoryRanges
With oWdRng.Find
If sh.Range("C" & i).Value <> "" Then
.Text = "_Name1"
.Replacement.Text = sh.Range("C" & i).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End If
If sh.Range("D" & i).Value <> "" Then
.Text = "_Name2"
.Replacement.Text = sh.Range("D" & i).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End If
End With
Next
For Each oWdTbl In .Tables
With oWdTbl
For r = .Rows.Count To 2 Step -1
For c = 1 To .Rows(r).Cells.Count Step 2
StrTxt = Split(.Cell(r, c).Range.Text, vbCr)(0)
If InStr(StrTxt, ";") > 0 Then
For j = 1 To UBound(Split(StrTxt, ";"))
If r = .Rows.Count Then
.Rows.Add
Else
.Rows.Add .Rows(r + 1)
End If
.Cell(r + j, c).Range.Text = Split(Trim(Split(StrTxt, ";")(j)), " ")(0)
.Cell(r + j, c + 1).Range.Text = Replace(Replace(Split(Trim(Split(StrTxt, ";")(j)), " ")(1), ")", ""), "(", "")
Next
End If
If InStr(StrTxt, " ") > 0 Then
.Cell(r, c).Range.Text = Split(Trim(Split(StrTxt, ";")(0)), " ")(0)
.Cell(r, c + 1).Range.Text = Replace(Replace(Split(Trim(Split(StrTxt, ";")(0)), " ")(1), ")", ""), "(", "")
End If
Next
Next
End With
Next
StrName = Sheets(1).Cells(i, 2).Text
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next j
StrName = Trim(StrName)
.SaveAs Filename:=sFolder & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
.SaveAs Filename:=sFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Next i
oWdApp.Quit
Set oWordDoc = Nothing: Set oWdApp = Nothing: Set oWdRng = Nothing: Set oWdTbl = Nothing: Set sh = Nothing
MsgBox "Succes"
End Sub