vba - 使用多行单元格从 word 复制粘贴表

Question

我有一个包含许多表格的 word 文档。我编写了一个脚本来检索从指定表号开始的表，即表 1、2、3 或 4 等(用户选择)。然后，该脚本将表格拉入 Excel 工作簿。我遇到的问题是所有表都有 4 列。第三列的内容包含多行，所以当它粘贴到 excel 时，它看起来很糟糕。我知道，如果您复制任何表格的第 3 列，双击 Excel 中的单元格并粘贴，它会粘贴在换行符中，因此看起来没问题。想知道是否有办法在vba中做到这一点。

这是我要复制到 Excel 中的表格:



这是脚本粘贴时的样子:



这是我需要它的样子:



这是我到目前为止所拥有的:

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

我发现这个解决方案仍然需要单元格迭代(不幸的是，当使用 Paste 、 PasteSpecial 或几个 CommandBars.ExecuteMso 选项直接粘贴到 Excel 时，换行符被视为单元格分隔符。

尝试用 vbCrLf 替换 Ascii 13 字符(回车 + 换行)并用空字符串替换 Ascii 7:

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

可能有一种更优雅的方法可以在不循环行/列的情况下执行此操作，但现在这应该可以工作。



我测试的实际代码

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