Insert adjustable table in Word document from 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.

Why in the first "result" example table are Name1 and Name3 are on the same line, but in the second table Name3 is on a line all by itself? Are there rules for that? — Tim Williams
The rule is, if the cell contains more than 1 value, Name3 should be in its own line. If the cell only contain one name, Name3 should be in the same line. So it depends on the number of ";", if there are none then one line, if there are one and more, it should be on its own line. Hope it clearifies. — User123456789

macropod macropod · Accepted Answer · 2020-12-22T00:19:34

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

Insert adjustable table in Word document from Excel

1 Answers