CODEWITHSUNDEEP
vbaexcel
Jane Alice
Jane Alice

Reputation: 91

Copy paste tables from word with multi-line cells

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:

enter image description here

Here is what it looks like it when the script pastes it in:

enter image description here

Here is what I needed it to look like:

enter image description here

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

Upvotes: 2

Views: 1032

Answers (1)

David Zemens
David Zemens

Reputation: 53623

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.

enter image description here

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

Upvotes: 1

Related Questions