Sub ExcelRangeToWord()
'Initialize
Application.ScreenUpdating = False
Dim WdApp As Word.Application, WdDoc As Word.Document, WdTbl As Word.Table, i 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.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)
  
      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
            'Insert report ref section # before item #
            .Cells(1).Range.InsertBefore (SecNum)
          End If
        End With
      Next i
    End With
    
    With .Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "Recommended Action"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
      End With
      Do While .Find.Execute
        If .Information(wdWithInTable) = True Then
          .End = .Cells(1).Range.End - 1
          .Style = wdStyleEmphasis
        End If
        .Collapse wdCollapseEnd
      Loop
    End With
  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