How to copy a formatted paragraph from Word 2013 to Excel?

Question

I want to open a Word document and copy each formatted paragraph into its own cell in an Excel worksheet, retaining the formatting for further processing. I have been able t

Answer 1

The answer will be a bit ugly. This way is normally not how you should write Excel macros, but here it goes:

...
Sheets(FileName).Cells(ParaCount, 1).Select
Sheets(FileName).Paste
...

Don't use .Select unless you need to.

Answer 2

There are a couple tricks to this and some things to keep in mind. First, the code:

Option Explicit

Sub ParaCopy()
    Dim wApp As Word.Application
    Dim wDoc As Word.Document
    Set wApp = CreateObject("Word.Application")
    Set wDoc = wApp.Documents.Open("C:\Temp\testdoc.docx", ReadOnly:=True)

    Dim i As Long
    i = 0
    Dim wPara As Word.Paragraph
    For Each wPara In wDoc.Paragraphs
        If wPara.Range.Words.Count > 1 Then
            wPara.Range.Copy
            Sheet1.Range("A1").Offset(i, 0).Activate
            Sheet1.Paste
            i = i + 1
        End If
    Next wPara

    wDoc.Close
    wApp.Quit
End Sub

So this works from two aspects:

1. We're using the Range.Copy method of the Word Paragraph. This captures all of the attributes of the paragraph including the formatting.
2. To copy into a specific cell, this is one of the rare instances in which using Activate is necessary. This signals to Excel that the upcoming Copy operation will apply all of attributes of the incoming object (which is a Word paragraph object in this case).

Make sure you check that the paragraph has at least one word in it. Otherwise the paste operation will fail.

Here's my test Word document:

And here is the workbook Sheet1 after the Paste:

Answer 3

For reference, the updated sub code is:

   Private Sub Load_Schedule()
    Dim ParaCount As Integer
    Sheets(FileName).Activate
    Sheets(FileName).Columns(1).AutoFit
    For ParaCount = 1 To wDoc.Paragraphs.Count
        wDoc.Paragraphs(ParaCount).Range.Copy
        Sheets(FileName).Range("A1").Offset(ParaCount, 0).Activate
        Sheets(FileName).Paste
    Next ParaCount
End Sub