Copy paste tables from word with multi-line cells - vba

Question

I have a word document that contains a number of tables. I've written a script to retrieve the tables starting at a specified table number i.e. table 1, 2, 3, or 4 and so on (user selects). The script then pulls the tables into an excel workbook. The problem I am having is that all of the tables have 4 columns. The 3rd column has content in it which contains multiple lines so when it pastes to excel, it looks bad. I understand that if you copy the 3rd column of any table, double click in a cell in excel and paste, it'll paste in the line breaks so it looks ok. Was wondering if there was a way to do this in vba.
Here is my table that I want to copy into Excel:
Here is what it looks like it when the script pastes it in:
Here is what I needed it to look like:
Here's what I have so far:
Option Explicit
Sub Macro1()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim tableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
Dim resultRow As Long
Dim tableStart As Integer
Dim tableTot As Integer
On Error Resume Next
ActiveSheet.Range("A:AZ").ClearContents
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file containing table(s) to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
With wdDoc
tableNo = wdDoc.Tables.Count
tableTot = wdDoc.Tables.Count
If tableNo = 0 Then
MsgBox "This document contains no tables", _
vbExclamation, "Import Word Table"
ElseIf tableNo > 1 Then
tableNo = InputBox("This Word document contains " & tableNo & " tables." & vbCrLf & _
"Enter the table to start from", "Import Word Table", "1")
End If
resultRow = 1
For tableStart = 1 To tableTot
With .Tables(tableStart)
'copy cell contents from Word table cells to Excel cells
For iRow = 1 To .Rows.Count
For iCol = 1 To .Columns.Count
Cells(resultRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
Next iCol
resultRow = resultRow + 1
Next iRow
End With
resultRow = resultRow + 1
Next tableStart
End With
End Sub

Answer 1

I've found this solution which still requires the cell-wise iteration (unfortunately the line breaks are treated as cell delimiters when Pasting directly to Excel using Paste, PasteSpecial or several of the CommandBars.ExecuteMso options.
Try replacing the Ascii 13 character with a vbCrLf (carriage return + line feed) and also replacing Ascii 7 with an empty string:
Dim thisText as String, newText as String
For tableStart = 1 To tableTot
With .Tables(tableStart)
'copy cell contents from Word table cells to Excel cells
For iRow = 1 To .Rows.Count
For iCol = 1 To .Columns.Count
thisText = .Cell(iRow, iCol).Range.Text
newText = Replace(thisText, Chr(13), vbCrLf)
newText = Replace(newText, Chr(7), vbNullString)
Cells(resultRow, iCol) = WorksheetFunction.Clean(newText)
Next iCol
resultRow = resultRow + 1
Next iRow
End With
resultRow = resultRow + 1
Next tableStart
There may be a more elegant way to do this without looping row/column, but for now this should work.
Actual code that I tested
Sub foo2()
Dim wdApp As Object, wdDoc As Object, wdTable As Object
Set wdApp = GetObject(, "Word.Application")
Set wdDoc = wdApp.Documents(1)
Set wdTable = wdDoc.Tables(1)
Dim iRow As Long, iCol As Long, resultRow As Long
Dim thisText As String, newText As String
resultRow = 1
With wdTable
For iRow = 1 To .Rows.Count
For iCol = 1 To .Columns.Count
thisText = .Cell(iRow, iCol).Range.Text
newText = Replace(thisText, Chr(13), vbCrLf)
newText = Replace(newText, Chr(7), vbNullString)
Cells(resultRow, iCol) = newText
Next iCol
resultRow = resultRow + 1
Next iRow
End With
End Sub