Populate word tables from an Excel table

Question

From our audit database I derive an Excel table like this one below. What I need to do is populate a table in a word template document with the content of the first row in the excel table, then drop a couple of lines and have a new table identical to the first one, but populated with the content of the second row in the excel table, and so on until I reach the end of the Excel table.

I know how to populate a Word table from Excel using Word bookmarks, but I am unsure how to do this kind of looping, and drop the lines after each table.

Any hint to put me on the right track will be greatly appreciated.

The code I have written so far is the below, which though copies the entire table in the bookmark, and not each line into a separate table as I would like it to be.

'Starting to generate the report in MsWord
Sheets("Data Table").Select

Set wdApp = New Word.Application
uName = Environ("Username")
fName = "C:\Users\" & uName & "\Form Templates\Custom Reports\Draft 
Report Template\Template.dotx"

With wdApp
    .Visible = True
    '.Activate
    .Documents.Open fName, , ReadOnly

    Sheets("Main Body of the Report").Select
    
    Range("C1").Select
    Selection.End(xlDown).Select
    Range("E1048576").Select
    Selection.End(xlUp).Select
    rNumber = ActiveCell.Row
      
    Range("D4:" & "E" & ActiveCell.Row).Select 'main body of the report
    Selection.Copy
    .Selection.Goto wdGoToBookmark, , , "MainBody"
    .Selection.PasteExcelTable False, False, False
    .Selection.Tables(1).Rows.Height = 0
    .Selection.Tables(1).PreferredWidthType = wdPreferredWidthPoints
    .Selection.Tables(1).PreferredWidth = CentimetersToPoints(16)
     
    .Selection.Find.ClearFormatting
    .Selection.Find.Replacement.ClearFormatting
    With .Selection.Find
        .Text = "Observations: "
        .Replacement.Text = "Observations:^t^t^t^t^t^t^t^t^t"
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    .Selection.Find.Execute Replace:=wdReplaceAll

End With

Answer 1

I have self-resolved the issue myself. Maybe not in the way I originally wanted, but it works and it satisfies our needs. Below the full code. I ended up generating the tables in Excel and the copying them into word and doing some formatting.

Sub RefreshData_Click()

Dim pvtTbl As PivotTable, aCell As String, rng As String, Cell As Range, vSortList As Variant, PT As PivotTable, wdApp As Word.Application, fName As String, uName As String, StartCell As Range, myList As Range, Y As Range, X As Range

'Data refresh based on project code
ActiveWorkbook.RefreshAll

'Generating various pivot tables with lists of recommendations, annex II, annex of low risk issues, main body of the report

Sheets("Main Body of the Report").Select

Range("D1").Select
Selection.End(xlDown).Select
Range("A1048576").Select
Selection.End(xlUp).Select
rNumber = ActiveCell.Row

Set myList = Range("A4:A" & rNumber)
    
    For Each X In myList
        If X.Font.Bold = True Then
            X.Select
            X.Copy
            Range("D" & ActiveCell.Row).Select
            ActiveSheet.Paste
            Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Merge
            Range("A" & ActiveCell.Row).Select
        End If
    Next

    For Each X In myList
        If Left(X, 11) = "Background:" Then
            X.Select
            X.Copy
            Range("D" & ActiveCell.Row).Select
            ActiveSheet.Paste
            With Range("D" & ActiveCell.Row)
                .Characters(Start:=1, Length:=11).Font.Bold = True
            End With
            Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Merge
            Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
            Range("A" & ActiveCell.Row).Select
        End If
    Next
    
    For Each X In myList
        If Left(X, 14) = "Residual risk:" Then
            X.Select
            X.Copy
            Range("D" & ActiveCell.Row).Select
            ActiveSheet.Paste
            Range("D" & ActiveCell.Row).Font.Bold = True
            Range("D" & ActiveCell.Row).Cells.HorizontalAlignment = xlHAlignJustify
            Range("D" & ActiveCell.Row).Value = "Observations: " & Range("D" & ActiveCell.Row).Value
            Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Merge
            Range("D" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
            Range("E" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
            Range("A" & ActiveCell.Row).Select
        End If
    Next

    For Each X In myList
        If Left(X, 12) = "Observation:" Then
            X.Select
            X.Copy
            Range("D" & ActiveCell.Row).Select
            ActiveSheet.Paste
            ActiveCell.Replace What:="Observation: ", Replacement:=""
            Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Merge
            Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
            Range("A" & ActiveCell.Row).Select
        End If
    Next
    
    For Each X In myList
        If Left(X, 7) = "Impact:" Then
            X.Select
            X.Copy
            Range("D" & ActiveCell.Row).Select
            ActiveSheet.Paste
            With ActiveCell.Characters(Start:=1, Length:=7)
                .Font.Bold = True
            End With
            Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Merge
            Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
            Range("A" & ActiveCell.Row).Select
        End If
    Next

    For Each X In myList
        If Left(X, 6) = "Cause:" Then
            X.Select
            X.Copy
            Range("D" & ActiveCell.Row).Select
            ActiveSheet.Paste
            With ActiveCell.Characters(Start:=1, Length:=6).Font
                .Bold = True
            End With
            Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Merge
            Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
            Range("A" & ActiveCell.Row).Select
        End If
    Next

    For Each X In myList
        If Left(X, 15) = "Recommendation:" Then
            X.Select
            X.Copy
            Range("D" & ActiveCell.Row).Select
            ActiveSheet.Paste
            ActiveCell.Replace What:="Recommendation: ", Replacement:="Recommendations:" & Chr(10) & Chr(10)
            ActiveCell.Font.Bold = True
            ActiveCell.BorderAround LineStyle:=xlContinuous, Weight:=xlThin
            Range("A" & ActiveCell.Row).Select
        End If
    Next

    For Each X In myList
        If Left(X, 9) = "Priority:" Then
            X.Select
            X.Copy
            Range("E" & ActiveCell.Row - 1).Select
            ActiveSheet.Paste
            ActiveCell.Replace What:="Priority: ", Replacement:="Priority:" & Chr(10) & Chr(10)
            ActiveCell.Font.Bold = True
            ActiveCell.BorderAround LineStyle:=xlContinuous, Weight:=xlThin
            ActiveCell.HorizontalAlignment = xlCenter
        End If
    Next

Range("C1").Select
Selection.End(xlDown).Select
Range("D1048576").Select
Selection.End(xlUp).Select
rNumber = ActiveCell.Row

Set myList = Range("D4:D" & rNumber)

    For Each X In myList
        If X.Value = "" Then
            X.Select
            Range(X.Address & ":E" & ActiveCell.Row).Delete Shift:=xlUp
        End If
    Next

Range("C1").Select
Selection.End(xlDown).Select
Range("D1048576").Select
Selection.End(xlUp).Select
rNumber = ActiveCell.Row

Set myList = Range("D4:D" & rNumber)

    For Each X In myList
        If X.Value = "" Then
            X.Select
            Range(X.Address & ":E" & ActiveCell.Row).Delete Shift:=xlUp
        End If
    Next
    
Range("C1").Select
Selection.End(xlDown).Select
Range("D1048576").Select
Selection.End(xlUp).Select
rNumber = ActiveCell.Row

Set myList = Range("D4:D" & rNumber)

    For Each X In myList
        If Left(X, 17) = "Recommendations:" & Chr(10) Then
            X.Select
            If Left(Range("D" & ActiveCell.Row + 1).Value, 17) = "Recommendations:" & Chr(10) Then
                Range("D" & ActiveCell.Row + 1).Value = Mid(Range("D" & ActiveCell.Row + 1).Value, 19, Len(Range("D" & ActiveCell.Row + 1).Value) - 18)
            End If
        End If
    Next

Range("C1").Select
Selection.End(xlDown).Select
Range("E1048576").Select
Selection.End(xlUp).Select
rNumber = ActiveCell.Row

Set myList = Range("E4:E" & rNumber)

    For Each X In myList
        If Left(X, 10) = "Priority:" & Chr(10) Then
            X.Select
            If Left(Range("E" & ActiveCell.Row + 1).Value, 10) = "Priority:" & Chr(10) Then
                Range("E" & ActiveCell.Row + 1).Value = Mid(Range("E" & ActiveCell.Row + 1).Value, 12, Len(Range("E" & ActiveCell.Row + 1).Value) - 11)
                Range("D" & ActiveCell.Row + 2 & ":E" & ActiveCell.Row + 2).Select
                Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                Range("D" & ActiveCell.Row).Value = "Management Response"
                Range("D" & ActiveCell.Row).HorizontalAlignment = xlCenter
                Range("D" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
                Range("D" & ActiveCell.Row).Interior.Color = 14277081
                Range("D" & ActiveCell.Row).Font.Bold = True
                Range("E" & ActiveCell.Row).Value = "Target Implementation Date"
                Range("E" & ActiveCell.Row).HorizontalAlignment = xlCenter
                Range("E" & ActiveCell.Row).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
                Range("E" & ActiveCell.Row).Interior.Color = 14277081
                Range("E" & ActiveCell.Row).Font.Bold = True
                Range("D" & ActiveCell.Row + 1 & ":E" & ActiveCell.Row + 1).Select
                Selection.Insert Shift:=xlDown
                Range("D" & ActiveCell.Row & ":E" & ActiveCell.Row).Select
                Selection.Borders(xlDiagonalDown).LineStyle = xlNone
                Selection.Borders(xlDiagonalUp).LineStyle = xlNone
                With Selection.Borders(xlEdgeLeft)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With Selection.Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With Selection.Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With Selection.Borders(xlEdgeRight)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With Selection.Borders(xlInsideVertical)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
                With Selection.Interior
                    .Pattern = xlNone
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                End With
            End If
        End If
    Next

Sheets("Annex II").Select

Range("C4").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="=""Ineffective"""
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="=""Effective"""
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 5287936
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    
Range("D4").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="=""High"""
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="=""Low"""
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 5287936
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="=""Moderate"""
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 49407
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    
'Starting to generate the report in MsWord
Sheets("Data Table").Select

Set wdApp = New Word.Application
uName = Environ("Username")
fName = "C:\Users\" & uName & "\World Health Organization\IOS Internal Audit - Form Templates\TeamMate Custom Reports\Draft Report Template\IOS Excel Utility\IOS Template.dotx"

With wdApp
    .Visible = True
    .Documents.Open fName, , ReadOnly

    Range("A2").Copy 'audit code
    .Selection.Goto wdGoToBookmark, , , "AuditCodeP1"
    .Selection.PasteSpecial , , , , wdPasteText
    .Selection.Goto wdGoToBookmark, , , "AuditCodeP2"
    .Selection.PasteSpecial , , , , wdPasteText
    .Selection.Goto wdGoToBookmark, , , "AuditCodeAI"
    .Selection.PasteSpecial , , , , wdPasteText
    .Selection.Goto wdGoToBookmark, , , "AuditCodeAII"
    .Selection.PasteSpecial , , , , wdPasteText
    .Selection.Goto wdGoToBookmark, , , "AuditCodeAIII"
    .Selection.PasteSpecial , , , , wdPasteText
    .Selection.Goto wdGoToBookmark, , , "AuditCodeAIV"
    .Selection.PasteSpecial , , , , wdPasteText
    
    Range("C6").Copy 'audit title
    .Selection.Goto wdGoToBookmark, , , "AuditTitleP1"
    .Selection.PasteSpecial , , , , wdPasteText
    .Selection.Goto wdGoToBookmark, , , "AuditTitleP2"
    .Selection.PasteSpecial , , , , wdPasteText
    .Selection.Goto wdGoToBookmark, , , "AuditTitleAI"
    .Selection.PasteSpecial , , , , wdPasteText
    .Selection.Goto wdGoToBookmark, , , "AuditTitleAII"
    .Selection.PasteSpecial , , , , wdPasteText
    .Selection.Goto wdGoToBookmark, , , "AuditTitleAIII"
    .Selection.PasteSpecial , , , , wdPasteText
    .Selection.Goto wdGoToBookmark, , , "AuditTitleAIV"
    .Selection.PasteSpecial , , , , wdPasteText
    
    If Len(Range("H6")) > 0 Then
        Range("H6").Copy 'executive summary
        .Selection.Goto wdGoToBookmark, , , "ExecutiveSummary"
        .Selection.PasteSpecial , , , , wdPasteText
    End If
    
    Sheets("Table of Recommendations").Select
    
    Range("A3").Select 'table of recommendations
    Range(Selection, Selection.End(xlToRight)).Select 'table of recommendations
    Range(Selection, Selection.End(xlDown)).Select 'table of recommendations
    Application.CutCopyMode = False
    Selection.Copy
    Range("H3").Select
    ActiveSheet.Paste
    Selection.Columns.AutoFit
    Application.CutCopyMode = False
    
    'merging and centering the bold lines
    Range("H4").Select
    Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 5)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Set StartCell = Range("H4")
    Set myList = Range("H4:H" & Range("H" & Rows.Count).End(xlUp).Row)
    For Each X In myList
        If X.Font.Bold = True Then
            X.Select
            Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 5)).Merge
        End If
    Next
    
    Range("H3").Select 'table of recommendations into the word document.
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Replace What:="(blank)", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Selection.Copy
    .Selection.Goto wdGoToBookmark, , , "TableOfRecommendations"
    .Selection.PasteExcelTable False, False, False
    .Selection.Tables(1).Rows(1).Select
    .Selection.Rows.HeadingFormat = True
    .Selection.Tables(1).Rows.Height = 0
    .Selection.Tables(1).Rows.Alignment = wdAlignRowCenter
    .Selection.Tables(1).PreferredWidthType = wdPreferredWidthPoints
    .Selection.Tables(1).PreferredWidth = CentimetersToPoints(16)
    
    Range("H3").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlToLeft
    
    Sheets("Data Table").Select
    
    If Len(Range("G6")) > 0 Then
        Range("G6").Copy 'introduction
        .Selection.Goto wdGoToBookmark, , , "Introduction"
        .Selection.PasteSpecial , , , , wdPasteText
    End If
    
    If Len(Range("F6")) > 0 Then
        Range("F6").Copy 'objective, scope, and approach
        .Selection.Goto wdGoToBookmark, , , "ObjectiveScopeApproach"
        .Selection.PasteSpecial , , , , wdPasteText
    End If
    
    If Len(Range("I6")) > 0 Then
        Range("I6").Copy 'audit conclusion
        .Selection.Goto wdGoToBookmark, , , "AuditConclusion"
        .Selection.PasteSpecial , , , , wdPasteText
    End If
    
    If Len(Range("H6")) > 0 Then
        Range("I6").Copy 'good practices
        .Selection.Goto wdGoToBookmark, , , "GoodPractices"
        .Selection.PasteSpecial , , , , wdPasteText
    End If
    
    Sheets("Annex II").Select
    Range("A3").Select 'annex II
    Range(Selection, Selection.End(xlToRight)).Select 'annex II
    Range(Selection, Selection.End(xlDown)).Select 'annex II
    Selection.Copy
    .Selection.Goto wdGoToBookmark, , , "AnnexII"
    .Selection.PasteExcelTable False, False, False
    .Selection.Tables(1).Rows(1).Select
    .Selection.Rows.HeadingFormat = True
    .Selection.Tables(1).Rows.Height = 0
    .Selection.Tables(1).Rows.Alignment = wdAlignRowCenter
    .Selection.Tables(1).PreferredWidthType = wdPreferredWidthPoints
    .Selection.Tables(1).PreferredWidth = CentimetersToPoints(16)
    
    Sheets("Annex of Low Risk Recs").Select
    Range("A3").Select 'Annex of Low Risk Recs
    Range(Selection, Selection.End(xlToRight)).Select 'Annex of Low Risk Recs
    Range(Selection, Selection.End(xlDown)).Select 'Annex of Low Risk Recs
    Application.CutCopyMode = False
    Selection.Copy
    Range("D3").Select
    ActiveSheet.Paste
    Selection.Columns.AutoFit
    Application.CutCopyMode = False
    
    'merging and centering the bold lines
    Range("D3").Select
    Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 1)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Set StartCell = Range("D4")
    Set myList = Range("D4:D" & Range("D" & Rows.Count).End(xlUp).Row)
    For Each Y In myList
        If Y.Font.Bold = True Then
            Y.Select
            Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 1)).Merge
        End If
    Next
    
    Range("D3").Select 'Annex of Low Risk Recs
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Replace What:="(blank)", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Selection.Copy
    
    .Selection.Goto wdGoToBookmark, , , "AnnexIII"
    .Selection.PasteExcelTable False, False, False
    .Selection.Tables(1).Rows(1).Select
    .Selection.Rows.HeadingFormat = True
    .Selection.Tables(1).Rows.Height = 0
    .Selection.Tables(1).Rows.Alignment = wdAlignRowCenter
    .Selection.Tables(1).PreferredWidthType = wdPreferredWidthPoints
    .Selection.Tables(1).PreferredWidth = CentimetersToPoints(16)
    Range("D3").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlToLeft
    
    Sheets("Main Body of the Report").Select
    
    Range("C1").Select
    Selection.End(xlDown).Select
    Range("E1048576").Select
    Selection.End(xlUp).Select
    rNumber = ActiveCell.Row
      
    Range("D4:" & "E" & ActiveCell.Row).Select 'main body of the report
    Selection.Copy
    .Selection.Goto wdGoToBookmark, , , "MainBody"
    .Selection.PasteExcelTable False, False, False
    .Selection.Tables(1).Rows.Height = 0
    .Selection.Tables(1).PreferredWidthType = wdPreferredWidthPoints
    .Selection.Tables(1).PreferredWidth = CentimetersToPoints(16)
     
    .Selection.Find.ClearFormatting
    .Selection.Find.Replacement.ClearFormatting
    With .Selection.Find
        .Text = "Observations: "
        .Replacement.Text = "Observations:^t^t^t^t^t^t^t^t^t"
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    .Selection.Find.Execute Replace:=wdReplaceAll

    Sheets("Main Body of the Report").Select
    Columns("D:E").Select
    Selection.Clear
    
    'Start from the top of the document
    wdApp.Selection.HomeKey wdStory
            
    sFindText = "|H1|"
    wdApp.Selection.Find.Execute sFindText
    Do Until wdApp.Selection.Find.Found = False
        wdApp.Selection.EndKey Unit:=wdLine, Extend:=wdExtend
        wdApp.Selection.Style = ActiveDocument.Styles("Heading 1")
        wdApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
        wdApp.Selection.ParagraphFormat.Space1
        wdApp.Selection.ParagraphFormat.SpaceBefore = 12
        wdApp.Selection.MoveRight
        wdApp.Selection.Find.Execute
    Loop
           
    wdApp.Selection.HomeKey wdStory
            
    sFindText = "|H2|"
    wdApp.Selection.Find.Execute sFindText
    Do Until wdApp.Selection.Find.Found = False
        wdApp.Selection.EndKey Unit:=wdLine, Extend:=wdExtend
        wdApp.Selection.Style = ActiveDocument.Styles("Heading 2")
        wdApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
        wdApp.Selection.ParagraphFormat.Space1
        wdApp.Selection.ParagraphFormat.SpaceAfter = 12
        wdApp.Selection.ParagraphFormat.SpaceBefore = 12
        wdApp.Selection.MoveRight
        wdApp.Selection.Find.Execute
    Loop
           
    wdApp.Selection.HomeKey wdStory
           
    wdApp.Selection.Find.ClearFormatting
    wdApp.Selection.Find.Replacement.ClearFormatting
    With wdApp.Selection.Find
        .Text = "|H1|"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
                
    wdApp.Selection.Find.Execute Replace:=wdReplaceAll
            
    With wdApp.Selection.Find
        .Text = "|H2|"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
                
    wdApp.Selection.Find.Execute Replace:=wdReplaceAll

End With

For Each sht In Application.Worksheets
    sht.Sort.SortFields.Clear
Next sht

Set xlApp = Excel.Application

With xlApp
    .Visible = True
    Sheets("Data Table").Select
    Range("A2").Select
    MsgBox "Report generated corectly in Ms Word. You may now close the Excel file.", vbOKOnly, "Good news!"
End With

End Sub