Generate table based on fields

[MacroWizard]

Hello everyone!

Hope you guys are doing well today. I have a new challenge that I'm facing and have only begun doing research on how to accomplish it.

single lesson.jpg

So I have a dynamic guide that has multiple lessons. The number of lessons vary and all begin with a prefabbed template (see above image). The highlighted items are items that I need to port over into a table that will be generated based on the number of lessons there are. An example is this:

course overview.jpg

So an example of code might be:

'Count the number of controls with the tag module and make that many rows in the table
Dim ctl As ContentControl
Dim rng As Range
For Each ctl In ActiveDocument.ContentControls
If ctl.Tag = "Module" Then
   x = x + 1
End If
Next
'
'
'Create the table with 3 columns and x number of rows
Set oTable = ActiveDocument.Tables.Add(Range:=rng, NumRows:=x, NumColumns:=3)
'
'
'Insert data into table based on when it is received in the loop.
'Each type of data goes it its own column (of 3) and each set goes into its own row.
With oTable
  For r = 1 To x
    For Each ctl In ActiveDocument.ContentControls
      If ctl.Tag = "Time" Then
        r = r + 1
        .Cell(Row:=r, Column:=1).Range.Text = ctl.Range.Text
      End If
      If ctl.Tag = "Module" Then
        .Cell(Row:=r, Column:=2).Range.Text = ctl.Range.Text
      End If
      If ctl.Tag = "Description" Then
        .Cell(Row:=r, Column:=2).Range.Text = ctl.Range.Text
      End If
    Next
  Next
End With
'
'Reset Values
Set oTable = Nothing: Set rng = Nothing

I realize that the code isn't functional or accurate. I am not quite sure where to go from here. Any help from you guys would greatly be appreciated.

Cheers to you master teachers out there.

[MacroWizard]

Right now I'm getting bad parameter on

Set oTable = ActiveDocument.Tables.Add(Range:=rng, NumRows:=x, NumColumns:=3)

Hopefully I'm headed in the right direction. I swear I've done like 10 progress edits to the main post.


EDIT:

Okay so I set the range, fixed that issue, but something is wrong with the code so that things don't show up where they are supposed to be. So the code is functional, but not quite where we want to be as far as functionality goes.

[gmayor]

You were going in then right direction, but your row counting was all over the place, which is why the table didn't work. Try the following (and do declare all your variables)

Option Explicit
Sub CreateTable()
'Count the number of controls with the tag module and make that many rows in the table
Dim oTable As Table
Dim ctl As ContentControl
Dim rng As Range
Dim x As Long, t As Long, m As Long, d As Long

    Set rng = ActiveDocument.Range
    rng.Collapse 0        'Put the range at the end of the document
    x = 1        'set the initial value for x
    t = 1: m = 1: d = 1        'set the initial values for t,m & d
    For Each ctl In ActiveDocument.ContentControls
        If ctl.Tag = "Module" Then
            x = x + 1
        End If
    Next
    '
    '
    'Create the table with 3 columns and x number of rows
    Set oTable = ActiveDocument.Tables.Add(Range:=rng, NumRows:=x, NumColumns:=3)
    oTable.Rows(1).Cells(1).Range.Text = "Time"
    oTable.Rows(1).Cells(2).Range.Text = "Module"
    oTable.Rows(1).Cells(3).Range.Text = "Description"
    oTable.Rows(1).Shading.BackgroundPatternColor = wdColorGray10

    '
    'Insert data into table based on when it is received in the loop.
    'Each type of data goes it its own column (of 3) and each set goes into its own row.
    With oTable
        For Each ctl In ActiveDocument.ContentControls
            If ctl.Tag = "Time" Then
                t = t + 1
                .Cell(Row:=t, Column:=1).Range.Text = ctl.Range.Text
            End If
            If ctl.Tag = "Module" Then
                m = m + 1
                .Cell(Row:=m, Column:=2).Range.Text = ctl.Range.Text
            End If
            If ctl.Tag = "Description" Then
                d = d + 1
                .Cell(Row:=d, Column:=3).Range.Text = ctl.Range.Text
            End If
        Next ctl
    End With
    '
    'Reset Values
    Set oTable = Nothing: Set rng = Nothing: Set ctl = Nothing
End Sub

[MacroWizard]

Graham,

Thanks for the tips. I can definitely see where I went wrong and I know why. I'll test this out tomorrow and report back here to let you know how it went. Thanks again!

[gmaxey]

There is nothing wrong with Graham's method, but as you said earlier you like to see alternative methods. Here is one that might introduce you to collections and also show you how to handle an error (an error that while perhaps unlikely, could occur and is unhandled in the method above). Graham, don't take that as a poke in the eye because the error has already poked mine.

Sub CreateTable()
Dim oTbl As Table
Dim oCC As ContentControl
Dim oColType_T As New Collection, oColType_M As New Collection, oColType_D As New Collection
Dim lngIndex As Long
  'Alternate method.
  'Loop through the document once and collect the CCs of interest.
  For Each oCC In ActiveDocument.ContentControls
    Select Case oCC.Tag
      Case "Time": oColType_T.Add oCC
      Case "Module": oColType_M.Add oCC
      Case "Description": oColType_D.Add oCC
    End Select
  Next oCC
  'Define and format the table.
  On Error GoTo Err_Interference
  'Note will error if the last thing in the document is a CC (so would your previous method)
  Set oTbl = ActiveDocument.Tables.Add(Range:=ActiveDocument.Range.Characters.Last, NumRows:=oColType_M.Count + 1, NumColumns:=3)
  On Error GoTo 0
  With oTbl
    With .Rows(1)
      .Cells(1).Range.Text = "Time"
      .Cells(2).Range.Text = "Module"
      .Cells(3).Range.Text = "Description"
      .Shading.BackgroundPatternColor = wdColorGray10
    End With
    'Put the CC data in the table.
    For lngIndex = 1 To oColType_T.Count
      .Cell(lngIndex + 1, 1).Range.Text = oColType_T.Item(lngIndex).Range.Text
      .Cell(lngIndex + 1, 2).Range.Text = oColType_M.Item(lngIndex).Range.Text
      .Cell(lngIndex + 1, 3).Range.Text = oColType_D.Item(lngIndex).Range.Text
    Next lngIndex
  End With
lbl_Exit:
  Exit Sub
Err_Interference:
  ActiveDocument.Range.InsertAfter vbCr
  Resume
End Sub

[MacroWizard]

Greg,

Very interesting post. Most of the work that I have done in VBA has been for MS Access. Oddly enough, I have never worked with collections before. They seem like a unique and useful functionality.

I chose to use yours for the final copy because I am not familiar with the collections method of doing things. So far, I have found it easy to work with.

Below is the final piece of coding. The only differences are that I adjusted the column widths to autofit the contents of the columns, and I set the button to first look to see if a table was already made. If there is a table, the table gets deleted and replaced with an updated table. It also is inserted into a specific place in the document, because it will always be on the same page.

Thank you both so much for your assistance. I have learned from both of you.

I think I wrote this in a way that it won't error out. Let me know if you guys see potential bugs.

Sub CreateTable()
    Dim oTbl As Table
    Dim oCC As ContentControl
    Dim oColType_T As New Collection, oColType_M As New Collection, oColType_D As New Collection
    Dim lngIndex As Long
     'Alternate method.
     '
     'Loop through the tables to select and delete the table with the ID called tblset
    For Each oTbl In ActiveDocument.Tables
        If oTbl.ID = "tblset" Then
           oTbl.Delete
        Else
        ' Do nothing
        End If
    Next oTbl
    On Error GoTo Err_Interference
     '
     '
     'Loop through the document once and collect the CCs of interest.
    For Each oCC In ActiveDocument.ContentControls
        Select Case oCC.Tag
        Case "Time": oColType_T.Add oCC
        Case "Module": oColType_M.Add oCC
        Case "Description": oColType_D.Add oCC
        End Select
    Next oCC
     '
     'Define and format the table.
    On Error GoTo Err_Interference
     '
     'Note will error if the last thing in the document is a CC (so would your previous method)
    Set oTbl = ActiveDocument.Tables.Add(Range:=ActiveDocument.Range.Characters.Last, NumRows:=oColType_M.Count + 1, NumColumns:=3)
    On Error GoTo 0
    With oTbl
            .ID = "tblset"
            .PreferredWidthType = wdPreferredWidthPercent
            .PreferredWidth = 100
        With .Rows(1)
            .Cells(1).Range.Text = "Time"
            .Cells(2).Range.Text = "Module"
            .Cells(3).Range.Text = "Description"
            .Shading.BackgroundPatternColor = wdColorGray10
        End With
         '
         'Put the CC data in the table.
        For lngIndex = 1 To oColType_T.Count
            .Cell(lngIndex + 1, 1).Range.Text = oColType_T.Item(lngIndex).Range.Text
            .Cell(lngIndex + 1, 2).Range.Text = oColType_M.Item(lngIndex).Range.Text
            .Cell(lngIndex + 1, 3).Range.Text = oColType_D.Item(lngIndex).Range.Text
        Next lngIndex
            .Columns.AutoFit
    End With
lbl_Exit:
    Exit Sub
Err_Interference:
    ActiveDocument.Range.InsertAfter ActiveDocument.ContentControls("crsOverview")
    Resume
End Sub

[gmaxey]

Just a couple minor suggestions. No point continuing the loop have you delete the table and your error handler was repeated twice.

Sub CreateTable()
Dim oTbl As Table
Dim oCC As ContentControl
Dim oColType_T As New Collection, oColType_M As New Collection, oColType_D As New Collection
Dim lngIndex As Long
  'Alternate method.
  'Loop through the tables to select and delete the table with the ID called tblset
  For Each oTbl In ActiveDocument.Tables
    If oTbl.ID = "tblset" Then
      oTbl.Delete
      Exit For 'Unless you think there are going to be multiple instances of the table there is no point continue the loop.
    End If
  Next oTbl
  'On Error GoTo Err_Interference - Repeated below.  You don't need it here.
  'Loop through the document once and collect the CCs of interest.
  For Each oCC In ActiveDocument.ContentControls
    Select Case oCC.Tag
      Case "Time": oColType_T.Add oCC
      Case "Module": oColType_M.Add oCC
      Case "Description": oColType_D.Add oCC
    End Select
  Next oCC
  'Define and format the table.
  On Error GoTo Err_Interference
  'Note will error if the last thing in the document is a CC (so would your previous method)
  Set oTbl = ActiveDocument.Tables.Add(Range:=ActiveDocument.Range.Characters.Last, NumRows:=oColType_M.Count + 1, NumColumns:=3)
  On Error GoTo 0
  With oTbl
    .ID = "tblset"
    .PreferredWidthType = wdPreferredWidthPercent
    .PreferredWidth = 100
    With .Rows(1)
      .Cells(1).Range.Text = "Time"
      .Cells(2).Range.Text = "Module"
      .Cells(3).Range.Text = "Description"
      .Shading.BackgroundPatternColor = wdColorGray10
    End With
    'Put the CC data in the table.
    For lngIndex = 1 To oColType_T.Count
      .Cell(lngIndex + 1, 1).Range.Text = oColType_T.Item(lngIndex).Range.Text
      .Cell(lngIndex + 1, 2).Range.Text = oColType_M.Item(lngIndex).Range.Text
      .Cell(lngIndex + 1, 3).Range.Text = oColType_D.Item(lngIndex).Range.Text
    Next lngIndex
    .Columns.AutoFit
  End With
lbl_Exit:
 Exit Sub
Err_Interference:
    ActiveDocument.Range.InsertAfter ActiveDocument.ContentControls("crsOverview")
    Resume
End Sub

[MacroWizard]

All,

So for some reason one of the controls is showing up twice in the resulting table. You can see this in the description column. Any ideas as to why this is?

I attached a document with the button to do this.

Image to illustrate:
Problem.jpg

tabletest.docm

[gmaxey]

Works here with three sets of CCs. Add a Stop at the error statement. Run the code to the stop and then using the locals windows see look at your oColType_D collection.

[MacroWizard]

Thanks, it is working now. I'll go ahead and set this one to solved. Hopefully someone else can use this in the future.

[gmaxey]

So what was the issue?

[MacroWizard]

The issue was with the controls that I had on the page. For some reason, a copy/paste was interfering with it.

Well I just reopened the thread. now the issue is with placement. I am attempting to have the table be inserted immediately after a contentcontrol called "crsOverview". I can't seem to properly grab the range without getting an error.

Attempted changing

Set oTbl = ActiveDocument.Tables.Add(Range:=ActiveDocument.Range.Characters.Last, NumRows:=oColType_M.Count + 1, NumColumns:=3)

to

Set oTbl = ActiveDocument.Tables.Add(Range:=ActiveDocument.ContentControls("crsOverview").Range.Characters.Last, NumRows:=oColType_M.Count + 1, NumColumns:=3)

Just gets an error. I suppose that would place it inside the CC. Just need to set some sort of placeholder and have it insert after.

[gmaxey]

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oTbl As Word.Table
  Dim strId As String
  'This will work provided the CC is not at the end of the document. Remove some of the .Next to see why.
  Set oTbl = ActiveDocument.Tables.Add(Range:=ActiveDocument.SelectContentControlsByTitle("crsOverview").Item(1).Range.Characters.Last.Next.Next.Next, NumRows:=5, NumColumns:=5)
  
  
  On Error GoTo Err_Explain
  'Note - You can't referred to CCs like:
  MsgBox ActiveDocument.ContentControls("crsOverview").Range.Text
  'But you can like this:
  MsgBox ActiveDocument.ContentControls(strId).Range.Text
  'Or like this:
  MsgBox ActiveDocument.ContentControls(1).Range.Text
lbl_Exit:
  Exit Sub
Err_Explain:
  MsgBox Err.Number & " " & Err.Description
  strId = ActiveDocument.SelectContentControlsByTitle("crsOverview").Item(1).ID
  Resume Next
End Sub

[MacroWizard]

I see, that's very interesting. I don't expect there to be a control at the end of the document, so fortunately that won't be an issue. Thanks for that. I think I'll keep your macro in my archive as a reminder of this. I can see how future coding projects could be affected.

(Marked SOLVED).

Thanks again Greg and Graham for all of the help. I can see why you two hold the MVP title.


Here is the final sub:

Sub CreateTable()
    Dim oTbl As Table
    Dim oCC As ContentControl
    Dim oColType_T As New Collection, oColType_M As New Collection, oColType_D As New Collection
    Dim lngIndex As Long
     'Alternate method.
     'Loop through the tables to select and delete the table with the ID called tblset
    For Each oTbl In ActiveDocument.Tables
        If oTbl.ID = "tblset" Then
            oTbl.Delete
            Exit For 'Unless you think there are going to be multiple instances of the table there is no point continue the loop.
        End If
    Next oTbl
     'On Error GoTo Err_Interference - Repeated below.  You don't need it here.
     'Loop through the document once and collect the CCs of interest.
    For Each oCC In ActiveDocument.ContentControls
        Select Case oCC.Tag
        Case "Time": oColType_T.Add oCC
        Case "Module": oColType_M.Add oCC
        Case "Description": oColType_D.Add oCC
        End Select
    Next oCC
     'Define and format the table.
    On Error GoTo Err_Interference
     'Note will error if the last thing in the document is a CC (so would your previous method)
    Set oTbl = ActiveDocument.Tables.Add(Range:=ActiveDocument.SelectContentControlsByTitle("crsOverview").Item(1).Range.Characters.Last.Next.Next.Next, NumRows:=oColType_M.Count + 1, NumColumns:=3)
    On Error GoTo 0
    With oTbl
        .ID = "tblset"
        .PreferredWidthType = wdPreferredWidthPercent
        .PreferredWidth = 100
        With .Rows(1)
            .Cells(1).Range.Text = "Time"
            .Cells(2).Range.Text = "Module"
            .Cells(3).Range.Text = "Description"
            .Shading.BackgroundPatternColor = wdColorGray10
        End With
         'Put the CC data in the table.
        For lngIndex = 1 To oColType_T.Count
            .Cell(lngIndex + 1, 1).Range.Text = oColType_T.Item(lngIndex).Range.Text
            .Cell(lngIndex + 1, 2).Range.Text = oColType_M.Item(lngIndex).Range.Text
            .Cell(lngIndex + 1, 3).Range.Text = oColType_D.Item(lngIndex).Range.Text
        Next lngIndex
        .Columns.AutoFit
    End With
lbl_Exit:
    Exit Sub
Err_Interference:
    ActiveDocument.Range.InsertAfter ActiveDocument.ContentControls("crsOverview")
    Resume
    Stop
End Sub