使用 VBA 合并 Word 表

Question

随附的Word文档包含表格（这是一个演示，实际上会有不确定数量的表格和未定义的行数）。

我想将它们全部合并到文档末尾的一个表中。
此外，标题行只能出现一次。

现在看起来像这样：

最后应该是这样的：

Sub waldenwald()

Sub walde()

    Dim t As Table, r As Row
    Dim i As Integer
  
    For Each t In ActiveDocument.Tables
        For Each r In t.Rows
            If r.Index > 1 Then
                For i = 1 To 5

                    ActiveDocument.Tables(i).Range.Copy
    
                    Set range2 = ActiveDocument.Content
                    range2.Collapse direction:=wdCollapseEnd
                    range2.Paste
    
                Next i
            End If
        Next r
    Next t

End Sub


Sub kopierensuperlean()

Dim i As Integer

For i = 1 To 5

    ActiveDocument.Tables(i).Range.Copy
    
    Set range2 = ActiveDocument.Content
    range2.Collapse direction:=wdCollapseEnd
    range2.Paste
    
Next i

End Sub

Answer 1

微软文档：

Range.Text 属性（Word）

Range.End 属性（Word）

Tables.Add 方法（Word）

选项 1：

• 将第一个带表头的表格复制到末尾，然后复制其他不带表头的表

Sub ConsolidateTablesCopyPaste()
    Dim doc As Document
    Dim mainTable As Table
    Dim tbl As Table, tblRange As Range
    Dim row As row, iCount As Long, iEnd As Long
    Dim colCount As Integer
    Dim i As Long, j As Long, k As Long
    Dim mergedTable As Table
    
    ' Set the document
    Set doc = ActiveDocument
    
    iCount = doc.Tables.Count
    ' Check if there are any tables in the document
    If iCount = 0 Then
        MsgBox "No tables found in the document."
        Exit Sub
    End If
    
    ' Insert a newline if doc is end with a table
    iEnd = doc.Content.End - 2
    If doc.Range(iEnd, iEnd).Information(wdWithInTable) Then
        doc.Characters.Last.InsertAfter vbCr
    End If
    
    ' Iterate through each table and copy the rows (except header row)
    For k = 1 To iCount
        Set tbl = doc.Tables(k)
        Set tblRange = tbl.Range.Duplicate
        If k > 1 Then
            tblRange.Start = tbl.Rows(2).Range.Start
        End If
        tblRange.Copy
        doc.Characters.Last.Paste
    Next k
End Sub

---

选项2：

• 先插入新表格，然后逐个复制单元格内容

Sub ConsolidateTables()
    Dim doc As Document
    Dim mainTable As Table
    Dim tbl As Table, iCount As Long, iEnd As Long
    Dim row As row, sTxt As String
    Dim colCount As Integer
    Dim i As Integer, j As Integer, k As Long
    Dim mergedTable As Table

    ' Set the document
    Set doc = ActiveDocument
    iCount = doc.Tables.Count
    ' Check if there are any tables in the document
    If iCount = 0 Then
        MsgBox "No tables found in the document."
        Exit Sub
    End If
    
    ' Create a new table at the end of the document
    colCount = doc.Tables(1).Columns.Count
    iEnd = doc.Content.End - 1
    If doc.Range(iEnd - 1, iEnd - 1).Information(wdWithInTable) Then
        doc.Characters.Last.InsertAfter vbCr
        iEnd = iEnd + 1
    End If
    Set mergedTable = doc.Tables.Add(Range:=doc.Range(iEnd, iEnd), NumRows:=1, NumColumns:=colCount)
    
    ' Copy the header row from the first table
    For i = 1 To colCount
        sTxt = doc.Tables(1).Cell(1, i).Range.Text
        mergedTable.Cell(1, i).Range.Text = Left(sTxt, Len(sTxt) - 2)
    Next i
    
    ' Append rows from all tables
    For k = 1 To iCount
        Set tbl = doc.Tables(k)
        ' Skip the header row
        For i = 2 To tbl.Rows.Count
            ' Add a new row to the merged table
            Set row = mergedTable.Rows.Add
            ' Copy each cell from the current row
            For j = 1 To colCount
                sTxt = tbl.Cell(i, j).Range.Text
                row.Cells(j).Range.Text = Left(sTxt, Len(sTxt) - 2)
            Next j
        Next i
    Next k
    mergedTable.Style = "List Table 3 - Accent 1" ' modify as needed
End Sub