Word VBA: Macro to change cells in selection, and create a summary table of the tables?

Question

I have a bunch of tables in a document that look roughly like this:

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

Figure 1
<Screenshot of Proof>

I'd like to make it look like this (Number in the upper left cell):

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

But, the there are many tables in the document, and I'd only like to use the ones "within selection".

In short: I have to take all tables within a selection and number them sequentially. I'd also like to make a table of these tables that looks like this:

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

Here is what I have so far:

Numbering Tables:

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

Table of Tables (with info):

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

But they flat out don't work the way I want them to, and I can't seem to manage to get them to work.

Could someone provide me with a solution?

Answer 1

We need to consider the following aspects for the macro to function as desired:

• A button or other object can't be used to invoke the macro, as that'll effectively change the selection. Instead, it can be run by either Alt + F8 or a short cut key assigned to the macro
• The selection must be continuous. So, if there are 4 tables, selection of just table# 1, & 3 won't work. It should rather be like table# 1 to 3.

With that and a few minor tweaks, the modified code as reproduced below should work.

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

Edit: the result for column Instances has been changed to "number of instances", rather than displaying the original values.

Answer 2

Here's a solution based on the comments. It's just based on reading your code without testing so hopefully this works. If it needs some tweaks, please feel free to edit.

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

Table of Tables (with info):

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