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:
Copy the table to a new word document. This is to avoid making changes to your original document.
Open the Find/Replace (CTRL-H) dialogue box.
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