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或其中的{{ 1}}选项。

尝试用CommandBars.ExecuteMso（回车+换行符）替换Ascii 13字符，并用空字符串替换Ascii 7：

vbCrLf

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

我测试过的实际代码

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

使用多行单元格从单词复制粘贴表

1 个答案: