Sub ExcelRangeToWord()
'Initialize
Application.ScreenUpdating = False
Dim WdApp As Word.Application, WdDoc As Word.Document, WdTbl As Word.Table, WdRng As Word.Range, i As Long, j As Long, k As Long
Const SecNum As String = "6."

'Instantiate Word
Set WdApp = CreateObject("Word.Application")

With WdApp
  'Make MS Word Visible
  .Visible = True
  'Create a New Document
  Set WdDoc = .Documents.Add
  'Copy Excel Table Range
  ThisWorkbook.Worksheets("InspectionPivot").PivotTables("InspectionPivot").TableRange2.Copy
  With WdDoc
    'Paste Table into MS Word
    .Paragraphs(1).Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
    Set WdTbl = .Tables(1)
    'Set Table column widths
    With WdTbl
      .Rows(1).HeadingFormat = True
      .Rows(1).Range.ParagraphFormat.KeepTogether = True
      .Rows(1).Range.ParagraphFormat.KeepWithNext = True
      .Rows.HeightRule = wdRowHeightAuto
      .Columns(1).Width = WdApp.CentimetersToPoints(0.5)
      .Columns(2).Width = WdApp.CentimetersToPoints(3)
      .Columns(3).Width = WdApp.CentimetersToPoints(11.5)
      .Columns(4).Width = WdApp.CentimetersToPoints(1)
      j = Split(.Rows(.Rows.Count).Cells(1).Range, ".")(0)
      
      For i = .Rows.Count To 2 Step -1
        With .Rows(i)
          If Len(.Range.Text) <= .Cells.Count * 3 + 2 Then
            'delete empty rows
            .Delete
          Else
            k = Split(.Cells(1).Range, ".")(0)
            'Insert report ref section # before item #
            .Cells(1).Range.InsertBefore (SecNum)
            'Split the table at a numbering change
            If j <> k And i > 2 Then
              j = k
              With WdTbl
                .Split .Rows(i + 1)
                .Range.Characters.Last.Next.FormattedText = .Rows(1).Range.FormattedText
                .Split .Rows(i + 1)
              End With
            End If
          End If
        End With
      Next i
    End With
  End With

  With WdRng
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = "Recommended Action"
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
    End With
    Do While .Find.Execute
      If .InRange(WdRng) = True Then
        .End = .Cells(1).Range.End - 1
        .Style = wdStyleEmphasis
      Else
        Exit Do
      End If
      .Collapse wdCollapseEnd
    Loop
  End With
  'Display Document
  .Activate
End With
'Clean Up
Set WdTbl = Nothing: Set WdDoc = Nothing: Set WdApp = Nothing
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub