Tables overwritten when exporting multiple tables from excel to word

Question

I am trying to use VBA to create a Word document with multiple tables each on a new page (using a loop) compiled with cell information from Excel.

So far everything works fantastically except after inserting the first table it is replaced by the second table, then the third table replaces the second, and so on. What I am left with is only the last created table.

I'm not sure how to cause a new table to be created instead of replacing the previously created table.

Screen shot of Excel table

Sub Export_to_Word()

    '(1) Word objects.
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    Dim wdCell As Word.Cell
    Dim wdTabl As Word.Table
    Dim wdRange As Word.Range
    
    
    '(2) Excel objects
    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
    Dim strValue As String
    Dim i As Integer
    Dim x As Integer
    
        'For assiging integer value to calculate number of table rows
        Dim ARows As Integer
        Dim BRows As Integer
        Dim CRows As Integer
        Dim DRows As Integer
    
        'For copying question part as a value in the excel sheet
        Dim QueNum As Variant
        Dim PartA As Variant
        Dim PartB As Variant
        Dim PartC As Variant
        Dim PartD As Variant
    
        'For copying the question in the excel sheet
        Dim QueA As Variant
        Dim QueB As Variant
        Dim QueC As Variant
        Dim QueD As Variant
        
        'For copying question part as a value in the excel sheet
        Dim MarkA As Variant
        Dim MarkB As Variant
        Dim MarkC As Variant
        Dim MarkD As Variant
        
        'For copying the answers in the excel sheet
        Dim AnsA As Variant
        Dim AnsB As Variant
        Dim AnsC As Variant
        Dim AnsD As Variant
        
        'For copying the header values in the excel sheet
        Dim CandCode As Variant
        Dim AnPath As Variant
        Dim Logo As Variant
        Dim EngNam As Variant
        Dim EngTex As Variant
        Dim FreNam As Variant
        Dim FreTex As Variant
        
    
    '(4) Initialize the Excel objects
    Set wbBook = ThisWorkbook
    Set wsSheet = wbBook.Worksheets("Sheet1")
    
    
    '(5)Create table in excel before copying to word
    'Create Word file.
    Set wdApp = New Word.Application
            wdApp.Visible = True
    Set wdDoc = wdApp.Documents.Add
        
    
    '(5a)Enter excel values into header
    With wdDoc.Sections(1)
        .Headers(wdHeaderFooterPrimary).Range.Text = CandCode & vbCr & vbCr & AnPath
        .Headers(wdHeaderFooterPrimary).Range.Font.Name = "Arial"
        .Headers(wdHeaderFooterPrimary).Range.Font.Size = 7
        .Headers(wdHeaderFooterPrimary).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
    End With
        
    '(5b)Start of new cycle for loop
    For i = 4 To 6
    
    '(5c) Equate cell values to the the variables defined under Excel objects (Part 2). N.B in equation "Cells(3,i) 3= row number and i=column number
        ARows = wsSheet.Cells(3, i).Value
        BRows = wsSheet.Cells(7, i).Value
        CRows = wsSheet.Cells(11, i).Value
        DRows = wsSheet.Cells(15, i).Value
        
        QueNum = wsSheet.Cells(1, i).Value
        PartA = wsSheet.Range("A2").Value
        PartB = wsSheet.Range("A6").Value
        PartC = wsSheet.Range("A10").Value
        PartD = wsSheet.Range("A14").Value
        
        QueA = wsSheet.Cells(2, i).Value
        QueB = wsSheet.Cells(6, i).Value
        QueC = wsSheet.Cells(10, i).Value
        QueD = wsSheet.Cells(14, i).Value
        
        MarkA = wsSheet.Cells(4, i).Value
        MarkB = wsSheet.Cells(8, i).Value
        MarkC = wsSheet.Cells(12, i).Value
        MarkD = wsSheet.Cells(16, i).Value
        
        AnsA = wsSheet.Cells(5, i).Value
        AnsB = wsSheet.Cells(9, i).Value
        AnsC = wsSheet.Cells(13, i).Value
        AnsD = wsSheet.Cells(17, i).Value
        
        CandCode = wsSheet.Range("V24").Value
        AnPath = wsSheet.Range("V25").Value
        Logo = wsSheet.Range("V26").Value
        EngNam = wsSheet.Range("V27").Value
        EngTex = wsSheet.Range("V28").Value
        FreNam = wsSheet.Range("V29").Value
        FreTex = wsSheet.Range("V30").Value
        
    '(5d)Creates variables that identifes location of each of the rows with the question part
        TotRows = ARows + BRows + CRows + DRows + 5
        QuesA_row = 2
        QuesB_row = ARows + 3
        QuesC_row = ARows + BRows + 4
        QuesD_row = ARows + BRows + CRows + 5
    
            
    '(5e)Create Word table
    Set wdRange = wdDoc.Range
        wdDoc.Tables.Add wdRange, NumRows:=(TotRows), NumColumns:=5, DefaultTableBehavior:=wdWord8TableBehavior, AutoFitBehavior:=wdAutoFitWindow
        
    Set wdTabl = wdDoc.Tables(1)
    
              
    '(5f)Edit Table
    With wdTabl
        .ApplyStyleHeadingRows = False
        .ApplyStyleLastRow = False
        .ApplyStyleFirstColumn = False
        .ApplyStyleLastColumn = True
        .ApplyStyleRowBands = False
        .ApplyStyleColumnBands = False
            
        'Changes font of table
        .Range.Font.Name = "Arial"
        .Range.Font.Size = "10"
            
        'Changes spacing of lines in table to single
        .Range.ParagraphFormat.SpaceBeforeAuto = False
        .Range.ParagraphFormat.SpaceBefore = 8
        .Range.ParagraphFormat.SpaceAfterAuto = False
        .Range.ParagraphFormat.SpaceAfter = 0
        .Range.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
        .Range.ParagraphFormat.PageBreakBefore = False
                  
        'Adjust column widths
        .Columns(1).SetWidth ColumnWidth:=20, RulerStyle:=wdAdjustNone
        .Columns(2).SetWidth ColumnWidth:=23, RulerStyle:=wdAdjustNone
        .Columns(3).SetWidth ColumnWidth:=400, RulerStyle:=wdAdjustNone
        .Columns(4).SetWidth ColumnWidth:=11, RulerStyle:=wdAdjustNone
        .Columns(5).SetWidth ColumnWidth:=40, RulerStyle:=wdAdjustNone
            
        'Shading for marks column & borders
        .Borders.Enable = False
        .Columns(5).Shading.BackgroundPatternColor = wdColorGray20
        .Columns(5).Borders(wdBorderTop).Color = wdColorBlack
            .Columns(5).Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
            .Columns(5).Borders(wdBorderTop).LineWidth = Options.DefaultBorderLineWidth
        .Columns(5).Borders(wdBorderLeft).Color = wdColorBlack
            .Columns(5).Borders(wdBorderLeft).LineStyle = Options.DefaultBorderLineStyle
            .Columns(5).Borders(wdBorderLeft).LineWidth = Options.DefaultBorderLineWidth
        .Columns(5).Borders(wdBorderRight).Color = wdColorBlack
            .Columns(5).Borders(wdBorderRight).LineStyle = Options.DefaultBorderLineStyle
            .Columns(5).Borders(wdBorderRight).LineWidth = Options.DefaultBorderLineWidth
        .Columns(5).Borders(wdBorderBottom).Color = wdColorBlack
            .Columns(5).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
            .Columns(5).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
        .Columns(5).Cells(1).Borders(wdBorderBottom).Color = wdColorBlack
            .Columns(5).Cells(1).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
            .Columns(5).Cells(1).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
                
        'Underlines for questions
        .Columns(3).Cells.Borders.InsideLineStyle = wdLineStyleSingle 'Adds bottom border to all cells in column 3
        .Columns(3).Cells(1).Borders(wdBorderBottom).Color = wdColorWhite 'Removes bottom border
            .Columns(3).Cells(1).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
            .Columns(3).Cells(1).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
        .Columns(3).Cells(QuesA_row).Borders(wdBorderBottom).Color = wdColorWhite 'Removes bottom border
            .Columns(3).Cells(QuesA_row).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
            .Columns(3).Cells(QuesA_row).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
        .Columns(3).Cells(QuesB_row).Borders(wdBorderBottom).Color = wdColorWhite 'Removes bottom border
            .Columns(3).Cells(QuesB_row).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
            .Columns(3).Cells(QuesB_row).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
        .Columns(3).Cells(QuesC_row).Borders(wdBorderBottom).Color = wdColorWhite 'Removes bottom border
            .Columns(3).Cells(QuesC_row).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
            .Columns(3).Cells(QuesC_row).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
        .Columns(3).Cells(QuesD_row).Borders(wdBorderBottom).Color = wdColorWhite 'Removes bottom border
            .Columns(3).Cells(QuesD_row).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
            .Columns(3).Cells(QuesD_row).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
        .Columns(3).Cells(TotRows).Borders(wdBorderBottom).Color = wdColorBlack 'Adds border to bottom row of column
            .Columns(3).Cells(TotRows).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
            .Columns(3).Cells(TotRows).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
    
        'Enter Data into table
        .Columns(1).Cells(2).Range.Text = QueNum & "."
                
        .Columns(2).Cells(QuesA_row).Range.Text = PartA
        .Columns(2).Cells(QuesB_row).Range.Text = PartB
        .Columns(2).Cells(QuesC_row).Range.Text = PartC
        .Columns(2).Cells(QuesD_row).Range.Text = PartD
            
        .Columns(3).Cells(QuesA_row).Range.Text = QueA
        .Columns(3).Cells(QuesB_row).Range.Text = QueB
        .Columns(3).Cells(QuesC_row).Range.Text = QueC
        .Columns(3).Cells(QuesD_row).Range.Text = QueD
            
        .Columns(5).Cells(1).Range.Text = "Marks"
        .Columns(5).Cells(QuesA_row).Range.Text = MarkA
        .Columns(5).Cells(QuesB_row).Range.Text = MarkB
        .Columns(5).Cells(QuesC_row).Range.Text = MarkC
        .Columns(5).Cells(QuesD_row).Range.Text = MarkD
                    
                    
        'Modifying marks column
        .Columns(5).Cells(1).Range.Font.Bold = True 'Modifys "marks" cell
            .Columns(5).Cells(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
            .Columns(5).Cells(1).Range.Cells.VerticalAlignment = wdCellAlignVerticalBottom
        .Columns(5).Cells(QuesA_row).Range.Font.Bold = True
            .Columns(5).Cells(QuesA_row).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
            .Columns(5).Cells(QuesA_row).Range.Cells.VerticalAlignment = wdCellAlignVerticalTop
        .Columns(5).Cells(QuesB_row).Range.Font.Bold = True
            .Columns(5).Cells(QuesB_row).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
            .Columns(5).Cells(QuesB_row).Range.Cells.VerticalAlignment = wdCellAlignVerticalTop
        .Columns(5).Borders(wdBorderTop).Color = wdColorBlack
            .Columns(5).Cells(QuesB_row).Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
            .Columns(5).Cells(QuesB_row).Borders(wdBorderTop).LineWidth = Options.DefaultBorderLineWidth
        .Columns(5).Cells(QuesC_row).Range.Font.Bold = True
            .Columns(5).Cells(QuesC_row).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
            .Columns(5).Cells(QuesC_row).Range.Cells.VerticalAlignment = wdCellAlignVerticalTop
        .Columns(5).Borders(wdBorderTop).Color = wdColorBlack
            .Columns(5).Cells(QuesC_row).Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
            .Columns(5).Cells(QuesC_row).Borders(wdBorderTop).LineWidth = Options.DefaultBorderLineWidth
        .Columns(5).Cells(QuesD_row).Range.Font.Bold = True
            .Columns(5).Cells(QuesD_row).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
            .Columns(5).Cells(QuesD_row).Range.Cells.VerticalAlignment = wdCellAlignVerticalTop
        .Columns(5).Borders(wdBorderTop).Color = wdColorBlack
            .Columns(5).Cells(QuesD_row).Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
            .Columns(5).Cells(QuesD_row).Borders(wdBorderTop).LineWidth = Options.DefaultBorderLineWidth
                
        'Adjusts text alignment in question column
        .Columns(3).Cells.VerticalAlignment = wdCellAlignVerticalBottom
                
        ' Exit table and insert page break so next table starts at beginning of page
            With wdRange
                .Collapse Direction:=wdCollapseEnd
                .InsertParagraphAfter
                .InsertBreak Type:=wdPageBreak
                .Collapse Direction:=wdCollapseEnd
            End With
        End With
    Next i
    
    
    '(7)Identifies all numbered words and replaces them with all caps bold
    Dim A(10) As String
        A(1) = "one"
        A(2) = "two"
        A(3) = "three"
        A(4) = "four"
        A(5) = "five"
        A(6) = "six"
        A(7) = "seven"
        A(8) = "eight"
        A(9) = "nine"
        A(10) = "ten"
        
    Set wdRange = ActiveDocument.Content
    With wdRange
        For x = 1 To 10
        .Find.ClearFormatting
        .Find.Replacement.ClearFormatting
        .Find.Replacement.Font.Bold = True
            With .Find
                .Forward = True
                .Wrap = wdFindStop
                .Format = False
                .MatchCase = False
                .MatchWholeWord = True
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Replacement.Font.Bold = True
                .Replacement.Font.Allcaps = True
                
                wdRange.Find.Execute FindText:=A(x), ReplaceWith:=A(x), Format:=True, _
                 Replace:=wdReplaceAll
            End With
        Next x
    End With
        
    '(8)Null out the variables.
    Set wdCell = Nothing
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Set wdRange = Nothing
    Set wdTabl = Nothing
    
    '(9) Adds message box to show complete
    MsgBox "Success! The exam questions are complete!", vbInformation


End Sub

The description for the first argument in `Tables.Add` is "The range where you want the table to appear. The table replaces the range, if the range isn't collapsed." You need to collapse the range to the end of the existing content (and then maybe add a new paragraph) before adding the next table. — Tim Williams, Jan 01 '18 at 04:30
Yes I thought of the collapse issue and did include a `.Collapse Direction:=wdCollapseEnd` function at the end of the content. I think it isn't working properly and I've spend several hours tweaking the content and location, but to no avail. — Joseph Andrews, Jan 01 '18 at 17:59

score 2 · Answer 1 · answered Jan 01 '18 at 21:25

This stripped-down version worked for me:

Sub Export_to_Word()

    Dim wdApp As Word.Application, i As Long, wdDoc As Word.Document
    Dim wdCell As Word.Cell, wdTabl As Word.Table, wdRange As Word.Range
    Dim wbBook As Workbook, wsSheet As Worksheet

    Set wbBook = ThisWorkbook
    Set wsSheet = wbBook.Worksheets("Sheet1")

    Set wdApp = New Word.Application
    wdApp.Visible = True
    Set wdDoc = wdApp.Documents.Add

    For i = 1 To 5
        wdDoc.Paragraphs.Add
        Set wdRange = ActiveDocument.Paragraphs.Last.Range

        Set wdTabl = wdDoc.Tables.Add(wdRange, NumRows:=5, NumColumns:=5, _
            DefaultTableBehavior:=wdWord8TableBehavior, _
            AutoFitBehavior:=wdAutoFitWindow)

        With wdTabl
            .Borders.Enable = True
            .Columns(1).Cells(1).Range.Text = "First"
            .Columns(5).Cells(5).Range.Text = "Last"
        End With
    Next i

End Sub

Thank you! I'm pretty new to VBA (and coding in general), but you reminded me of the important problem solving method of simplifying the code to it's bare necessities. Essentially the problem was that I had `Set wdRange = ActiveDocument.Range` this selected the entire range of the document and replaced the old table with the next table in the loop. Changing to `wdRange = ActiveDocument.Paragraphs.Last.Range` did the trick and solved my problem. — Joseph Andrews, Jan 04 '18 at 03:59

score 0 · Answer 2 · answered Jan 01 '18 at 06:48

You set up only one table.

 '(5e)Create Word table
    Set wdRange = wdDoc.Range
        wdDoc.Tables.Add wdRange, NumRows:=(TotRows), NumColumns:=5, DefaultTableBehavior:=wdWord8TableBehavior, AutoFitBehavior:=wdAutoFitWindow

    Set wdTabl = wdDoc.Tables(1)

Change code.

'(5e)Create Word table
Set wdRange = wdDoc.Range
Set wdTabl = wdDoc.Tables.Add(wdRange, NumRows:=(TotRows), NumColumns:=5, DefaultTableBehavior:=wdWord8TableBehavior, AutoFitBehavior:=wdAutoFitWindow)

'Set wdTabl = wdDoc.Tables(1)

That is a an excellent suggestion. I made the changes you suggested so that a new table is created. However, the same problem is still occurring. — Joseph Andrews, Jan 01 '18 at 17:52

Tables overwritten when exporting multiple tables from excel to word

Screen shot of Excel table

2 Answers2