Word VBA：宏可以更改選擇中的單元格，並創建表的匯總表？

Question

我在文檔中有一堆表，看起來像這樣：

| Thing     |   Title   |
|-----------|:---------:|
| Info      | A, B, C.  |
| Score     | Foo       |
| More Info | Long Text |
| Proof     | Blah      |

Figure 1
<Screenshot of Proof>

我想使它看起來像這樣（左上角單元格中的數字）：

| Thing #1  |       Title       |
|-----------|:-----------------:|
| Info      | A, B, C.          |
| Score     | Foo               |
| More Info | Long Text         |
| Proof     | Blah <Screenshot> |

但是，文檔中有很多表，我只想使用“在選擇范圍內”的表。

簡而言之：我必須將所有表格都放在一個選擇中，並對其進行順序編號。 我還想制作一個如下表的表：

| Number | Title | Score | Number of CSV's in Info |
|--------|:-----:|-------|-------------------------|
| 1      | Thing | Foo   | 3                       |
| ...    | ...   | ...   | ...                     |
| ...    | ...   | ...   | ...                     |
| ...    | ...   | ...   | ...                     |    

這是我到目前為止的內容：

編號表：

Sub NumberTablesSelection()
    Dim t As Integer

    Dim myRange as Range
    Set myRange = Selection.Range

    With myRange
        For t = 1 To .Tables.Count
            Set myCell = .Tables(t).Cell(1,1).Range
            myCell.Text = "Thing #" + t
            Next t
        End With
End Sub

表格表（帶信息）：

Sub TableOfThings()
    Dim t As Integer

    Dim myRange as Range
    Set myRange = Selection.Range

    myTable = Tables.Add(Range:=tableLocation, NumRows:=1, NumColumns:=4)
    myTable.Cell(1,1).Range.Text = "Number"
    myTable.Cell(1,2).Range.Text = "Title"
    myTable.Cell(1,3).Range.Text = "Score"
    myTable.Cell(1,4).Range.Text = "Instances"

    With myRange
        For t = 1 To .Tables.Count

            Set Title = .Tables(t).Cell(1,2).Range 
            Set Instances = .Tables(t).Cell(2,2).Range
            Set Score = .Tables(t).Cell(3,2).Range

            Set NewRow = myTable.Rows.Add
            NewRow.Cells(1).Range.Text = t
            NewRow.Cells(2).Range.Text = Title
            NewRow.Cells(3).Range.Text = Score
            NewRow.Cells(4).Range.Text = Instances
        End With
End Sub

但是它們完全無法按照我想要的方式工作，而且我似乎無法設法使它們正常工作。

有人可以為我提供解決方案嗎？

Answer 1

我們需要考慮以下方面，宏才能按需運行：

• 按鈕或其他對象不能用於調用宏，因為這將有效地更改選擇。 而是可以通過Alt + F8或分配給宏的快捷鍵來運行
• 選擇必須是連續的。 因此，如果有4個表，則僅選擇表1和3將無效。 它應該類似於表1至3。

有了這些和一些小的調整，下面復制的修改后的代碼應該可以工作。

Option Explicit
Sub NumberTablesSelection()
    Dim t As Integer, myRange, myCell As Range
    Set myRange = Selection.Range
    With myRange
        For t = 1 To .Tables.Count
            Set myCell = .Tables(t).Cell(1, 1).Range
            myCell.Text = "Thing #" & t
        Next t
    End With
End Sub
Sub TableOfThings()
    Dim t As Integer, myRange As Range, myTable As Table, NewRow As Row, Title As String, Instances As Integer, Score As String
    Set myRange = Selection.Range
    Selection.EndKey Unit:=wdStory
    Set myTable = ActiveDocument.Tables.Add(Range:=Selection.Range, NumRows:=1, NumColumns:=4)
    With myTable
        .Style = "Table Grid"
        .Rows(1).Shading.BackgroundPatternColor = -603917569
        .Cell(1, 1).Range.Text = "Number"
        .Cell(1, 2).Range.Text = "Title"
        .Cell(1, 3).Range.Text = "Score"
        .Cell(1, 4).Range.Text = "Instances"
    End With
    With myRange
        For t = 1 To .Tables.Count
            Title = .Tables(t).Cell(1, 2).Range
            Instances = UBound(Split(.Tables(t).Cell(2, 2).Range, ",")) + 1
            Score = .Tables(t).Cell(3, 2).Range
            Set NewRow = myTable.Rows.Add
            With NewRow
                .Shading.BackgroundPatternColor = wdColorAutomatic
                .Cells(1).Range.Text = t
                .Cells(2).Range.Text = txtClean(Title)
                .Cells(3).Range.Text = txtClean(Score)
                .Cells(4).Range.Text = Instances
            End With
        Next t
    End With
End Sub
Function txtClean(txt As String) As String
    txt = Replace(txt, Chr(7), "")
    txt = Replace(txt, Chr(13), "")
    txt = Replace(txt, Chr(11), "")
    txtClean = txt
End Function

編輯：結果列Instances已更改為“實例數”，而不是顯示原始值。

Answer 2

這是基於評論的解決方案。 它只是基於讀取代碼而不進行測試的，因此希望它可以工作。 如果需要一些調整，請隨時進行編輯。

Sub NumberTablesSelection()
    Dim t As Integer

    Dim myRange as Range
    Set myRange = Selection.Range

    With myRange
        For t = 1 To .Tables.Count
            Set myCell = .Tables(t).Cell(1,1)
            myCell.Range.Text = "Thing #" & t
            Next t
        End With
End Sub

表格表（帶信息）：

Sub TableOfThings()
    Dim t As Integer
    Dim tbl as Table
    Dim myRange as Range
    Set myRange = Selection.Range

    myTable = Tables.Add(Range:=tableLocation, NumRows:=1, NumColumns:=4)
    myTable.Cell(1,1).Range.Text = "Number"
    myTable.Cell(1,2).Range.Text = "Title"
    myTable.Cell(1,3).Range.Text = "Score"
    myTable.Cell(1,4).Range.Text = "Instances"

    t = 1
    For each tbl in myRange.Tables
        With tbl
            Set Title = .Cell(1,2).Range 
            Set Instances = .Cell(2,2).Range
            Set Score = .Cell(3,2).Range
        End With

       Set NewRow = myTable.Rows.Add
       With NewRow
           .Cells(1).Range.Text = t
           .Cells(2).Range.Text = Title
           .Cells(3).Range.Text = Score
           .Cells(4).Range.Text = Instances
      End With
      t = t + 1
    Next tbl

End Sub