Getting text from Word to Excel using VBA

So far I have close to working code that parses the document and gets heading, title and text between two titles. The content I am trying to extract has bullets, line break, etc and I would like to maintain the format when I paste it into a cell. Have been looking around and reading a lot of forums but unable to figure out how to keep the formatting intact. I looked into PasteSpecial but that pastes the content across multiple cells plus I would like to avoid copy/paste if possible.

Below's a very early code I have (has bugs that I am debugging/fixing):

Sub GetTextFromWord()

Dim Paragraph As Object, WordApp As Object, WordDoc As Object
Dim para As Object
Dim paraText As String
Dim outlineLevel As Integer
Dim title As String
Dim body As String
Dim myRange As Object
Dim documentText As String
Dim startPos As Long
Dim stopPos As Long
Dim file As String
Dim i As Long
Dim category As String

startPos = -1
i = 2

Application.ScreenUpdating = True
Application.DisplayAlerts = False


file = "C:\Sample.doc"
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
Set WordDoc = WordApp.Documents.Open(file)

Set myRange = WordDoc.Range
documentText = myRange.Text

For Each para In ActiveDocument.Paragraphs
    ' Get the current outline level.
    outlineLevel = para.outlineLevel

    ' Cateogry/Header begins outline level 1, and ends at the next outline level 1.
    If outlineLevel = wdOutlineLevel1 Then 'e.g., 1 Header
        category = para.Range.Text
    End If

    ' Set category as value for cells in Column A
    Application.ActiveWorkbook.Worksheets("Sheet1").Cells(i - 1, 1).Value = category

    ' Title begins outline level 1, and ends at the next outline level 1.
    If outlineLevel = wdOutlineLevel2 Then ' e.g., 1.1
        ' Get the title and update cells in Column B
        title = para.Range.Text
        Application.ActiveWorkbook.Worksheets("Sheet1").Cells(i, 2).Value = title

        startPos = InStr(nextPosition, documentText, title, vbTextCompare)

        If startPos <> stopPos Then
            ' this is text between the two titles
            body = Mid$(documentText, startPos, stopPos)
            ActiveSheet.Cells(i - 1, 3).Value = body
        End If

        stopPos = startPos
        i = i + 1

    End If


Next para


WordDoc.Close
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub

Link to Sample Doc