Turning a Word table into Excel

If you want to copy a table from Word to Excel, there's a trick to fix carriage returns and line feeds so they don't end up as merged cells.

There is one little catch: you need to swap line feeds and carriage returns before pasting, and after pasting you need to swap the line feeds back. My preference is to use the emoticon tongue sign :-Þ because it's easy to type (ALT-0222).

Follow this procedure to convert the markups into real formatting:

1. Copy the table to a new word document. This is to avoid making changes to your original document.

2. Open the Find/Replace (CTRL-H) dialogue box.

3. To stop Excel from introducing breaks and merged cells, Replace All ^l (line break) with Þ (ALT-0222):

4. Similarly, Replace All ^p (line break) with Þ (ALT-0222).

5. Open Excel.

6. Copy and paste the entire table into Excel. This will preserve the formatting.

7. In Excel, open the Find/Replace (CTRL-H) dialogue box.

8. Replace ALL Þ (ALT-0222) with Line Feed LF (ALT-010). 

Note that this can change some formatting, as Excel is not very good at remembering formatting. If you have character formatting, you will need to run this macro (which works with all character lengths, including over 255 characters):

Sub Replace_With_LF_interactive()

' Edward Chan 2003

Dim OrigRng As Range

Dim NewRng As Range

On Error GoTo quit

Set OrigRng = Application.InputBox("Select the range to replace Þ:" & Chr(10) & "Note: This a very slow operation!!", "Replace Þ", Application.Selection.Address, Type:=8)

Set NewRng = Application.InputBox("Select the range to put the output:", "Replace Þ", Application.Selection.Address, Type:=8)

On Error GoTo 0

If WorksheetFunction.CountA(NewRng.Address) <> 0 Then

   intanswer = MsgBox("The output range is not blank. Would you like to continue?", vbOKCancel, "Please Confirm")

   If intanswer = vbCancel Then Exit Sub

End If

Call Replace_With_LF(OrigRng, NewRng)

quit:

End Sub

Sub Replace_With_LF(OrigRng As Range, NewRng As Range)

' Edward Chan 2003

Dim rng As Range

Dim charIndex As Long

Dim formatArray() As Variant

Dim newValue As String

c = 0

' Grab all the formatting in the cell as a separate array

For Each rng In OrigRng

    c = c + 1

    ' This subroutine takes a long time because Excel is very slow when doing character.font operations.

    ' It's possible to copy out the text into Word and use this to get each character

    ' formatting instead. But doing that is also pretty slow, o well.

    charIndex = InStr(1, rng.Value, "Þ")

    If charIndex > 0 Then

        newValue = Replace(rng.Value, "Þ", Chr(10))

        ReDim formatArray(1 To Len(newValue) + Len(newValue) - Len(rng.Value), 1 To 16)

        j = 0

        For i = 1 To Len(newValue)

            j = j + 1

            formatArray(j, 1) = rng.Characters(i, 1).Font.Name

            formatArray(j, 2) = rng.Characters(i, 1).Font.FontStyle

            formatArray(j, 3) = rng.Characters(i, 1).Font.Size

            formatArray(j, 4) = rng.Characters(i, 1).Font.Strikethrough

            formatArray(j, 5) = rng.Characters(i, 1).Font.Superscript

            formatArray(j, 6) = rng.Characters(i, 1).Font.Subscript

            formatArray(j, 7) = rng.Characters(i, 1).Font.OutlineFont

            formatArray(j, 8) = rng.Characters(i, 1).Font.Shadow

            formatArray(j, 9) = rng.Characters(i, 1).Font.Underline

            On Error Resume Next ' Some characters don't have ThemeColor, they just have Color.

            formatArray(j, 10) = rng.Characters(i, 1).Font.ThemeColor

            On Error GoTo 0

            formatArray(j, 11) = rng.Characters(i, 1).Font.Color

            formatArray(j, 12) = rng.Characters(i, 1).Font.TintAndShade

            formatArray(j, 13) = rng.Characters(i, 1).Font.ThemeFont

            formatArray(j, 14) = rng.Characters(i, 1).Font.Bold

            formatArray(j, 15) = rng.Characters(i, 1).Font.Italic

            formatArray(j, 16) = rng.Characters(i, 1).Font.ColorIndex

            If rng.Characters(i, 1).text = "Þ" And _

               rng.Characters(i, 1).Font.Color = RGB(255, 0, 0) Then ' It's a red Þ so ignore it

                newValue = Left(newValue, j - 1) & Mid(newValue, j + 1) ' Remove it from the text

                j = j - 1 ' Go back one character

            ElseIf rng.Characters(i - 1, 2).text = "Þ " And _

               rng.Characters(i, 1).Font.Color = RGB(0, 0, 255) Then ' It's a blue "Þ " so ignore the space. This is to fix the way Word compares.

                newValue = Left(newValue, j - 1) & Mid(newValue, j + 1) ' Remove the space from the text

                j = j - 1 ' Go back one character

            ElseIf rng.Characters(i, 1).text = "Þ" Then

                formatArray(j, 1) = rng.Characters(i, 1).Font.Name

                formatArray(j, 2) = rng.Characters(i, 1).Font.FontStyle

                formatArray(j, 3) = rng.Characters(i, 1).Font.Size

                formatArray(j, 4) = rng.Characters(i, 1).Font.Strikethrough

                formatArray(j, 5) = rng.Characters(i, 1).Font.Superscript

                formatArray(j, 6) = rng.Characters(i, 1).Font.Subscript

                formatArray(j, 7) = rng.Characters(i, 1).Font.OutlineFont

                formatArray(j, 8) = rng.Characters(i, 1).Font.Shadow

                formatArray(j, 9) = rng.Characters(i, 1).Font.Underline

                On Error Resume Next

                formatArray(j, 10) = 0

                formatArray(j, 10) = rng.Characters(i, 1).Font.ThemeColor

                On Error GoTo 0

                formatArray(j, 11) = rng.Characters(i, 1).Font.Color

                formatArray(j, 12) = rng.Characters(i, 1).Font.TintAndShade

                formatArray(j, 13) = rng.Characters(i, 1).Font.ThemeFont

                formatArray(j, 14) = rng.Characters(i, 1).Font.Bold

                formatArray(j, 15) = rng.Characters(i, 1).Font.Italic

                formatArray(j, 16) = rng.Characters(i, 1).Font.ColorIndex

            End If

        Next i

        NewRng.Value = newValue

        Dim startIndex As Long

        Dim endIndex As Long

        startIndex = 1

        endIndex = 1

        For i = 2 To Len(newValue)

            If Not (formatArray(i, 1) = formatArray(i - 1, 1) And _

                    formatArray(i, 2) = formatArray(i - 1, 2) And _

                    formatArray(i, 3) = formatArray(i - 1, 3) And _

                    formatArray(i, 4) = formatArray(i - 1, 4) And _

                    formatArray(i, 5) = formatArray(i - 1, 5) And _

                    formatArray(i, 6) = formatArray(i - 1, 6) And _

                    formatArray(i, 7) = formatArray(i - 1, 7) And _

                    formatArray(i, 8) = formatArray(i - 1, 8) And _

                    formatArray(i, 9) = formatArray(i - 1, 9) And _

                    formatArray(i, 10) = formatArray(i - 1, 10) And _

                    formatArray(i, 11) = formatArray(i - 1, 11) And _

                    formatArray(i, 12) = formatArray(i - 1, 12) And _

                    formatArray(i, 13) = formatArray(i - 1, 13) And _

                    formatArray(i, 14) = formatArray(i - 1, 14) And _

                    formatArray(i, 15) = formatArray(i - 1, 15) And _

                    formatArray(i, 16) = formatArray(i - 1, 16)) Then

                endIndex = i - 1

                With NewRng.Characters(startIndex, endIndex - startIndex + 1).Font

                    .Name = formatArray(startIndex, 1)

                    .FontStyle = formatArray(startIndex, 2)

                    .Size = formatArray(startIndex, 3)

                    .Strikethrough = formatArray(startIndex, 4)

                    .Superscript = formatArray(startIndex, 5)

                    .Subscript = formatArray(startIndex, 6)

                    .OutlineFont = formatArray(startIndex, 7)

                    .Shadow = formatArray(startIndex, 8)

                    .Underline = formatArray(startIndex, 9)

                    If Not formatArray(startIndex, 10) = 0 Then

                        .ThemeColor = formatArray(startIndex, 10) ' Some characters don't have ThemeColor

                    Else

                        .Color = formatArray(startIndex, 11)

                    End If

                    .TintAndShade = formatArray(startIndex, 12)

                    .ThemeFont = formatArray(startIndex, 13)

                    .Bold = formatArray(startIndex, 14)

                    .Italic = formatArray(startIndex, 15)

                    .ColorIndex = formatArray(startIndex, 16)

                End With

                startIndex = i

            End If

        Next i

        ' Apply formatting to the last run of characters

        endIndex = Len(newValue)

        With NewRng.Characters(startIndex, endIndex - startIndex + 1).Font

            .Name = formatArray(startIndex, 1)

            .FontStyle = formatArray(startIndex, 2)

            .Size = formatArray(startIndex, 3)

            .Strikethrough = formatArray(startIndex, 4)

            .Superscript = formatArray(startIndex, 5)

            .Subscript = formatArray(startIndex, 6)

            .OutlineFont = formatArray(startIndex, 7)

            .Shadow = formatArray(startIndex, 8)

            .Underline = formatArray(startIndex, 9)

            If Not formatArray(startIndex, 10) = 0 Then

                .ThemeColor = formatArray(startIndex, 10) ' Some characters don't have ThemeColor

            Else

                .Color = formatArray(startIndex, 11)

            End If

            .TintAndShade = formatArray(startIndex, 12)

            .ThemeFont = formatArray(startIndex, 13)

            .Bold = formatArray(startIndex, 14)

            .Italic = formatArray(startIndex, 15)

            .ColorIndex = formatArray(startIndex, 16)

        End With

    ElseIf rng.Address <> NewRng(c).Address Then ' Copy cell to new location if a different cell

        rng.Copy

        NewRng(c).PasteSpecial (xlPasteAll)

    End If

Next rng

NewRng.Select

quit:

End Sub