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

Question

我已经设法使用VBA将一个表复制并粘贴到excel中，但最终结果并不是我所期望的。

在我想解决的一些单元格中存在换行问题。

例如，

我在一个表格中有一个文字，有一些像

这样的换行符

“这是阳光灿烂的日子，我们有以下选择：”

   a) Go shopping

   b) Stay Indoor

这个问题是，一旦将它导入excel，点a和b就不再位于excel的同一个单元格中。 Excel将其作为新单元格插入，而不是将点格式化为单个单元格。

我尝试使用find和replace将linebreak ^ p替换为空白，但字母a和b将作为空格删除。我不想将我的a和b替换为空格。我仍然需要将它们插入excel单元格。

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

您可以尝试搜索＆amp;替换为回车字符：Chr(10)

<强> [编辑] 好吧，我找不到直接处理你的问题的方法，也许更好的vba专家可能会找到解决方案。

我找到的解决方法是在粘贴它们之后连接单元格的值，因为没有其他方法可以保持格式化（我调整了Excel代码以使其在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

的问候，
最大