Word VBA 解决复制粘贴到 excel 时的换行或段落标记问题

Question

I have managed to copy and paste a table in word using VBA into excel but the end result isn\t quite what I have expected.

There is this problem of a linebreak issue in some of my cells that I would like to solve.

For example,

I have a text in a table in word with certain linebreak like

"This is a sunny day and we have the following options:"

   a) Go shopping

   b) Stay Indoor

The problem with this is that once it is imported into excel, point a and b is no longer in the same cell in excel. Excel inserted it as a new cell each instead of formatting the points into a single cell.

I have tried to use find and replace to replace the linebreak ^p into blank but the letter a and b would be removed as space. I don't want to replace my a and b as space. I still need them to be inserted into the excel cell.

Sub CreateExcel()

Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim tableWord As Word.Table


Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False

Set xlWB = xlApp.Workbooks.Add ' create a new workbook
'declare the cell to put the text in
With xlWB.Worksheets(1)
     Set tableWord = ActiveDocument.Tables(1)
     tableWord.Range.Copy
    .Paste Destination:=xlWB.Worksheets(1).Range("A1")

    xlApp.Dialogs(xlDialogSaveAs).Show
End With

xlWB.Close False ' close the workbook without saving
xlApp.Quit ' close the Excel application
Set xlWB = Nothing
Set xlApp = Nothing

End Sub

Answer 1

You can try to search & replace with the Carriage Return character: Chr(10)

[EDIT] Well, i can't find a way to deal straight forward with your issue, maybe a better vba expert may find a solution.

The workaround i found is to concatenate the values of the cell after you pasted them because there is no other way to keep formatting either (i adapted my Excel code to make it usable in Word vba):

Option Explicit

Sub CreateExcel()

Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim tableWord As Word.Table
Dim cell As Excel.Range, rUsed As Excel.Range, target As Excel.Range
Dim val As String

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
'xlApp.Visible = False

Set xlWB = xlApp.Workbooks.Add ' create a new workbook
'declare the cell to put the text in
With xlWB.Worksheets(1)
     Set tableWord = ActiveDocument.Tables(1)
     tableWord.Range.Copy
    .Paste Destination:=xlWB.Worksheets(1).Range("A1")

    'Select used range to get every cell that was pasted and has content
    Set rUsed = xlWB.Worksheets(1).UsedRange
    Set target = rUsed.Cells(1, 1)
    'Get the value of each cell and concatenate its value
    For Each cell In rUsed
        If cell.Value <> "" Then
            val = val + cell.Value + Chr(10)
            cell.ClearContents
        End If
    Next cell
    'Remove last carriage return
    target.Value = Left(val, Len(val) - 1)

    xlApp.Dialogs(xlDialogSaveAs).Show
End With

xlWB.Close False ' close the workbook without saving
xlApp.Quit ' close the Excel application
Set xlWB = Nothing
Set xlApp = Nothing
End Sub

Regards,
Max