title: Getting text from Word to Excel using VBA
body: <p>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.</p>
  
  <p>Below's a very early code I have (has bugs that I am debugging/fixing):</p>
  
  <pre><code>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 &lt;&gt; 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
  </code></pre>
  
  <p><a href="https://docs.google.com/file/d/0B_UNDFf6UzJHZHk3VC0xelFnV0U/edit" rel="nofollow">Link to Sample Doc</a></p>