excelvbams-word

Can't create tables automatically in Word document from Excel VBA

I'm trying to create a Word document from an Excel workbook. It loops through a number of sheets creating one page in Word per sheet in Excel. Creating basic text works just fine. It's when I try to create a table on each page that it gets weird. It looks like during creation, a table is created on the first page for a second and then disappears. Then, no tables at all.

Here is the code:

Sub Create_Contact_Log2()
Dim wdApp As Word.Application
Set wdApp = New Word.Application
With wdApp
    .Visible = True
    .Activate
    .Documents.Add.PageSetup.Orientation = wdOrientLandscape
End With

Dim ExcludeArray() As Variant
Dim ws As Worksheet
Dim month As String
Dim year As String
Dim tbl As Table

month = ActiveWorkbook.Worksheets("SET DATE").Range("C1")
year = ActiveWorkbook.Worksheets("SET DATE").Range("E1")


Dim InTheList As Boolean

' Sheets to exclude from loop
ExcludeArray = Array("SET DATE", "Crisis Schedule", "STATS", "ACTT Staff - Contact Numbers", "TCL Housing Status", "Client Address List", "ITT", "KPI", "HOSPITALIZATIONS", "OFFICE DATA ENTRY", "Contact Log", "TOP", "BOTTOM")




For Each ws In ActiveWorkbook.Worksheets
    InTheList = Not (IsError(Application.Match(ws.name, ExcludeArray, 0)))
    
    ' Loop through sheets to create Word pages
    If Not InTheList Then
        Dim client As String
        client = ws.Range("A35")
        
        With wdApp.Selection
        .ParagraphFormat.Alignment = wdAlignParagraphCenter
        .Font.name = "Calibri"
        .Font.Size = 20
        ' Header
        .TypeText month & " " & year
        
        .TypeParagraph
        .BoldRun
        .ParagraphFormat.Alignment = wdAlignParagraphRight
        .Font.name = "Calibri"
        .Font.Size = 11
        .TypeText "Client: "
        .BoldRun
        .TypeText client
        
        .TypeParagraph
        .ParagraphFormat.Alignment = wdAlignParagraphLeft
        .BoldRun
        .TypeText "Case responsible: "
        .BoldRun
        .TypeText ws.Range("A26") & "    "
        
        .BoldRun
        .TypeText "Auth Due: "
        .BoldRun
        .TypeText ws.Range("B30") & "    "
        
        .BoldRun
        .TypeText "APCP Due: "
        .BoldRun
        .TypeText ws.Range("B26") & "    "
        
        .BoldRun
        .TypeText "UD PCP Due: "
        .BoldRun
        .TypeText ws.Range("B28") & "    "
        
        .BoldRun
        .TypeText "ITT Due: "
        .BoldRun
        .TypeText ws.Range("C28")
        
        
        ' Create the table
        
        Set MyRange = ActiveDocument.Content
        MyRange.Collapse Direction:=wdCollapseEnd
        Set tbl = ActiveDocument.Tables.Add(Range:=MyRange, NumRows:=4, NumColumns:=6)
        
        tbl.Style = "Table Grid"
        
        With tbl.Rows(1)
        .Cells(1).Range.Text = "Day"
        .Cells(2).Range.Text = "Staff"
        .Cells(3).Range.Text = "Type"
        .Cells(4).Range.Text = "-X +"
        .Cells(5).Range.Text = "Plan"
        .Cells(6).Range.Text = "Actual/Response, Stage of change"
        .Range.Font.Bold = True
        .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
        .Cells.VerticalAlignment = wdCellAlignVerticalCenter
        End With
        
        
        .InsertNewPage
        End With
    End If
Next
Solution

  • I am sure there are many paths this coding could take. Following is what I can get to work. It does not use Selection method and that caused complications for bolding text but a solution was possible.

    Sub Create_Contact_Log2()
Dim ExcludeArray() As Variant
Dim ws As Worksheet
Dim month As String
Dim year As String
Dim tbl As Table
Dim client As String
Dim wdApp As Word.Application
Dim doc As Word.Document
Dim rng As Word.Range
Dim bld As Word.Range
Dim i As Integer
Dim InTheList As Boolean
Dim startPos As Integer
Dim tblHdr As String
Dim TargetWords As Variant
i = 1

Set wdApp = New Word.Application
With wdApp
    .Visible = True
    .Activate
    ' Turn off screen updating for speed
    .ScreenUpdating = False
    Set doc = .Documents.Add
    doc.PageSetup.Orientation = wdOrientLandscape
End With

month = ActiveWorkbook.Worksheets("SET DATE").Range("C1")
year = ActiveWorkbook.Worksheets("SET DATE").Range("E1")

' Sheets to exclude from loop
ExcludeArray = Array("Sheet1") ' Array("SET DATE", "Crisis Schedule", "STATS", "ACTT Staff - Contact Numbers", "TCL Housing Status", "Client Address List", "ITT", "KPI", "HOSPITALIZATIONS", "OFFICE DATA ENTRY", "Contact Log", "TOP", "BOTTOM")

For Each ws In ActiveWorkbook.Worksheets
    InTheList = Not (IsError(Application.Match(ws.Name, ExcludeArray, 0)))
    
    ' Loop through sheets to create Word pages
    If Not InTheList Then
        client = ws.Range("A35")
        
        ' Insert a page break except before the first page
        If i > 1 Then
            doc.Content.InsertAfter vbCr
            doc.Paragraphs.Last.Range.InsertBreak Type:=wdPageBreak
        End If
        
        ' Insert page header text
        Set rng = doc.Paragraphs.Last.Range
        With rng
        .Text = month & " " & year
        .ParagraphFormat.Alignment = wdAlignParagraphCenter
        .Font.Name = "Calibri"
        .Font.Size = 20
        .InsertParagraphAfter
        End With
        
        ' Insert client text
        Set rng = doc.Paragraphs.Last.Range
        With rng
        .Text = "Client: " & client
        .ParagraphFormat.Alignment = wdAlignParagraphRight
        .Font.Size = 11
        .Font.Name = "Calibri"
        .Font.Bold = False
        .InsertParagraphAfter
        End With
        
        ' Insert table header text
        Set rng = doc.Paragraphs.Last.Range
        With rng
        tblHdr = "Case responsible: " & ws.Range("A26") & "    "
        tblHdr = tblHdr & "Auth Due: " & ws.Range("B30") & "    "
        tblHdr = tblHdr & "APCP Due: " & ws.Range("B26") & "    "
        tblHdr = tblHdr & "UD PCP Due: " & ws.Range("B28") & "    "
        tblHdr = tblHdr & "ITT Due: " & ws.Range("C28")
        .Text = tblHdr
        .ParagraphFormat.Alignment = wdAlignParagraphLeft
        .InsertParagraphAfter
        End With

        ' Create table
        Set rng = doc.Paragraphs.Last.Range
        Set tbl = doc.Tables.Add(rng, 4, 6)
        tbl.Style = "Table Grid"
        With tbl.Rows(1)
        .Cells(1).Range.Text = "Day"
        .Cells(2).Range.Text = "Staff"
        .Cells(3).Range.Text = "Type"
        .Cells(4).Range.Text = "-X +"
        .Cells(5).Range.Text = "Plan"
        .Cells(6).Range.Text = "Actual/Response, Stage of change"
        .Range.Font.Bold = True
        .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
        .Cells.VerticalAlignment = wdCellAlignVerticalCenter
        End With
            
        ' Move range to end again after inserting table
        Set rng = doc.Range(doc.Content.End - 1)

        i = i + 1
    End If
Next
   
' List of words to bold (case-insensitive by default)
TargetWords = Array("Client:", "Case responsible:", "Auth Due:", "APCP Due:", "UD PCP Due:", "ITT Due:")

' Loop through each word in the list
For i = LBound(TargetWords) To UBound(TargetWords)
    With doc.Content.Find
        .ClearFormatting
        .Text = TargetWords(i)
        .Replacement.ClearFormatting
        .Replacement.Font.Bold = True
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = True
        .Execute Replace:=wdReplaceAll
    End With
Next i
 
wdApp.ScreenUpdating = True
End Sub