CODEWITHSUNDEEP
excelvbams-word
excelshir
excelshir

Reputation: 11

How to copy table from Word to Excel while preserving formatting

I've been coding VBA for many years but this one is a real head-scratcher.

The task is simple - Copy data from a table from Microsoft Word to Microsoft Excel.

The challenge: Maintain the formatting of the data from Word, which includes bulleted lists and multiple paragraphs. More specifically, I need to include all that formatted text from a cell from the Word table inside a single cell in the corresponding Excel table.

Solutions I've already tried and specifically where I got stuck:

METHOD 01: Select the entire table in Word, select a single cell in Excel, and paste.

Sub Method01_CopyAndPaste()

ActiveDocument.Tables(1).Select
Documents(1).ActiveWindow.Selection.Copy
Cells(1, 1).Select
ActiveSheet.Paste

End Sub

PROBLEM WITH METHOD 01: Excel creates multiple rows and merged cells whenever there are multiple paragraphs in the Word Table.

METHOD 02: Loop through the Word table, and assign all the contents to a Array (variant). Then loop through the Excel table and assign the values from the Array into the table.

Sub Method02_Array()

Dim r As Integer
Dim c As Integer
Dim AryTblData(1 To 10, 1 To 10) As Variant

'Loop through the 10x10 Source table and assign all values to 2 dimensional array
For r = 1 To 10
    For c = 1 To 10
        AryTblData(r, c) = ActiveDocument.Tables(1).Cell(r + 1, c)
    Next c
Next r

'Paste the array values into the activesheet starting at cell(1,1)
For r = 1 To 10
    For c = 1 To 10
        Cells(r, c) = WorksheetFunction.Clean(AryTblData(r, c))
    Next c
Next r

End Sub

PROBLEM WITH METHOD 02: The formatting is not preserved. Specifically, the bullet points do not appear in the Excel table.

METHOD 03: Use Application.Sendkeys to simulate the process of manually going to one cell of the Word table, copying it, going to the corresponding cell in the Excel table, pasting it, pressing {TAB} to go to the next cell, and then repeating this process for the total number of cells in the table.

Sub Method03_Sendkeys()

Dim r As Integer
Dim c As Integer

'Loop through the 3x3 Source table and simulate sending keys to copy and paste, cell by cell
For r = 1 To 3
    For c = 1 To 3

        'Activate Microsoft Word window
        AppActivate ("word"), True

        'Select the appropriate cell in the Word table (based on the For Loop)
        ActiveDocument.Tables(1).Cell(r, c).Select

        'In Word, copy the selection
        Application.SendKeys "^c", True

        'Activate Microsoft Excel window
            'Note: I'm not sure why AppActivate ("excel") does not work, but
            'for some reason Application.caption works for me.
        AppActivate Application.Caption, True

        'Select the appropriate cell in the active Excel worksheet (based on the For Loop)
        Cells(r, c).Select

        'In Excel, edit cell contents
        Application.SendKeys "{F2}", True

        'In Excel, Paste
        Application.SendKeys "^v", True

        'In Excel, Save changes to cell and move 1 cell to the right
        Application.SendKeys "{TAB}", True

    Next c
Next r

End Sub

PROBLEM WITH METHOD 03: It works with only 1 cell, but as soon as I attempt to get more than one cell copied and pasted over, the result is the same data over and over again across multiple cells.

QUESTION: Is this task even possible to achieve in VBA? I'd love to find a simple and elegant solution, but at this point I would settle for something that WORKS.

Thanks so much for your help!

Upvotes: 1

Views: 1796

Answers (2)

Sharon
Sharon

Reputation: 1

For pasting multiple lines from Word or a pdf into a single cell in Excel - click on the cell, press F2, then paste the text. That keeps it all in one cell. However it does not keep the formatting including colors and strikeouts

Upvotes: 0

freeflow
freeflow

Reputation: 4355

Following on from my comment, the following might work. I can't test as I don't have your source data

Sub Method02_Array()

Dim r As Integer
Dim c As Intege

For r = 1 To 10
    For c = 1 To 10
        ActiveDocument.Tables(1).Cell(r + 1, c).Range.Copy
        ActiveWorkbook.Sheets(1).Cells(r, c).Range.PasteSpecial operation:=xlPasteSpecialOperationNone, Paste:=xlPasteAll
    Next c
Next r

End Sub

Upvotes: 0

Related Questions