Sub ExcelRangeToWord()

Dim tbl As PivotTable
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table

'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False

'Copy Range from Excel
  Set tbl = ThisWorkbook.Worksheets("InspectionPivot").PivotTables("InspectionPivot")

'Create an Instance of MS Word
  On Error Resume Next
    
    'Is MS Word already opened?
      Set WordApp = GetObject(class:="Word.Application")
    
    'Clear the error between errors
      Err.Clear

    'If MS Word is not already open then open MS Word
      If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")
    
    'Handle if the Word Application is not found
      If Err.Number = 429 Then
        MsgBox "Microsoft Word could not be found, aborting."
        GoTo EndRoutine
      End If

  On Error GoTo 0
  
'Make MS Word Visible and Active
  WordApp.Visible = True
  WordApp.Activate
    
'Create a New Document
  Set myDoc = WordApp.Documents.Add
  
'Copy Excel Table Range
  tbl.TableRange2.Copy

'Paste Table into MS Word
  myDoc.Paragraphs(1).Range.PasteExcelTable _
    LinkedToExcel:=False, _
    WordFormatting:=False, _
    RTF:=False
  
'set column widths
Set WordTable = myDoc.Tables(1)
    With WordTable
                WordTable.Columns(1).Width = CentimetersToPoints(0.5)
                WordTable.Columns(2).Width = CentimetersToPoints(3)
                WordTable.Columns(3).Width = CentimetersToPoints(11.5)
                WordTable.Columns(4).Width = CentimetersToPoints(1)
    End With

'delete empty rows
    With WordTable
        noOfCol = WordTable.Range.Rows(1).Cells.Count
                For i = .Rows.Count To 1 Step -1
                    With .Rows(i)
                        If Len(.Range) = noOfCol * 2 + 2 Then .Delete
                    End With
                Next i
    End With

'Insert report refrence section number before item numbers

    Dim SecNum As String
    Dim RefCell As Cell
        SecNum = "6."
    
        For Each RefCell In WordTable.Range.Columns(1).Cells
          RefCell.Range.InsertBefore (SecNum)
         Next RefCell

'format report text in column 3
   
Dim oTbl As Table
Dim oRow As Row
Dim oRng As Word.Range
Dim rngFormat As Word.Range
Dim bltFormat As Word.Range
Dim Fnd As Boolean
Dim Fnd2 As Boolean

Dim WrdFind As Find

Dim pos1 As Long
Dim pos2 As Long

Set oTbl = ActiveDocument.Tables(1)

For Each oTbl In ActiveDocument.Tables





         
  For Each oRow In WordTable.Rows
  
    Set oRng = oRow.Cells(3).Range
    
    'Replace line brakes with paragraph and set spacing after to 0
    oRow.Cells(3).Range = Replace(oRow.Cells(3).Range.Text, vbVerticalTab, vbCrLf)
    oRow.Cells(3).Range.ParagraphFormat.SpaceAfter = 0
    
    'Make first para bold
    oRow.Cells(3).Range.Paragraphs(1).Range.Bold = True
    
    'Find and italiscise text folowing "Reccomended Action"
   Set rngFormat = oRow.Cells(3).Range
        With rngFormat.Find
        .ClearFormatting
        .Execute FindText:="Recommended Action", Forward:=False, _
                 Format:=False, Wrap:=wdFindStop
        Fnd = .Found
    End With
   
    If Fnd = True Then
         With rngFormat
             .MoveEnd Unit:=wdCell, Count:=1
             
             With .Font
                 .Italic = True
             End With
         End With
     End If
   
       
    'Bullet non bold or italic text
    Set bltFormat = oRow.Cells(3).Range
        With bltFormat.Find
        .Execute FindText:="Recommended Action", Forward:=False, _
                 Format:=False, Wrap:=wdFindStop
        Fnd = .Found
    End With
   
    If Fnd = True Then
         With bltFormat
               .MoveEnd Unit:=wdParagraph, Count:=-1
               .MoveStart Unit:=wdCell, Count:=-1
               .MoveStart Unit:=wdParagraph, Count:=1
             bltFormat.ListFormat.ApplyBulletDefault
         End With
     End If
   
  Next
Next

EndRoutine:


'Optimize Code
  Application.ScreenUpdating = True
  Application.EnableEvents = True

'Clear The Clipboard
  Application.CutCopyMode = False

End Sub