'Find and italiscise text folowing "Reccomended Action"
    pos1 = InStr(oRng, "Reccomended Action")
    pos2 = oRow.Cells(3).Range.End
        rngFormat = oRng.Range(Start:=pos1, End:=pos2)
        
        rngFormat.Italic = True

Sub ExcelRangeToWord()

'Includes  multiple edits and adaptations from original source
'PURPOSE: Copy/Paste An Excel Table Into a New Word Document
'NOTE: Must have Word Object Library Active in Order to Run _
  (VBE > Tools > References > Microsoft Word 12.0 Object Library)
'SOURCE: www.TheSpreadsheetGuru.com

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 Range
Dim rngFormat As Word.Range
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
    oRow.Cells(3).Range = Replace(oRow.Cells(3).Range.Text, vbVerticalTab, vbCrLf)
    
    'Make first para bold
    oRow.Cells(3).Range.Paragraphs(1).Range.Bold = True
    
    'Find and italiscise text folowing "Reccomended Action"
    pos1 = InStr(oRng, "Reccomended Action")
    pos2 = oRow.Cells(3).Range.End
        rngFormat = oRng.Range(Start:=pos1, End:=pos2)
        
        rngFormat.Italic = True
   
     
  Next
  
  
Next

EndRoutine:


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

'Clear The Clipboard
  Application.CutCopyMode = False

End Sub