Iterate And add ContentControls in Word VBA Macro

Question

I have a hundreds of word documents that have multiple tables. Each table row has a specific custom style that was applied that identifies the data that goes in the cell. The need is to iterate through the word document, find the style, and add a ContentControl on that item. The issue that I have is the Selection.Find command restarts at the beginning of the document, so it ends up nesting ContentControls. I have tried adding in some counting mechanism, but while it fixes most of the issues, it leaves off at least some of the ContentControls and does have a few nests. I have tried only searching on a specific table but the Selection.Find overrides the selected table. Is there a way to iterate from the beginning of the document to the end so that I can dynamically add the content controls? Each document has 2 different types of tables. There will be only 1 of the following tables:

There can be 1 to 100 of this table:

The contentControl is supposed to encapsulate the data in the Document Level Metadata column. Here is the code I have up to this point

                Option Explicit

            Sub FindStyleReplaceWithCC()
            Dim CCtrl As ContentControl
            Do While ActiveDocument.ContentControls.Count > 0
                For Each CCtrl In ActiveDocument.ContentControls
                If CCtrl.LockContentControl = True Then CCtrl.LockContentControl = False
                CCtrl.Delete False
            Next
            Loop

            'For Each CCtrl In ActiveDocument.ContentControls
                'For Each CCtrl In ActiveDocument.ContentControls
                '    MsgBox (CCtrl.Range)
                'Next

            'Dim CCtrl As ContentControl
            Dim sty As Style
            Dim oTbl As Table
            ''''''''''''''''''''''''''''''''''''''''
            'Table 1
            Dim thearray(1 To 13, 1 To 2)
             Dim element As Variant
            Dim arrWsNames() As Variant
            Dim I As Integer
            arrWsNames = Array("Sensitive Information Protection", "Applies To", "Functional Org", "Functional Process Owner", _
            "Topic Owner", "Subject Matter Experts", "Author", "Corporate Source ID", "Superior Source", "CIPS Legacy Document", _
            "Meta-Roles(DocLvl)", "SME Reviewer", "SourceDocs")

            For I = 1 To 13
            thearray(I, 1) = arrWsNames(I - 1)
            thearray(I, 2) = 0
            Next


            Dim howmany As Integer
            howmany = 0

            For Each element In arrWsNames

            Dim iterations As Integer
                        With Selection.Find
                            .ClearFormatting
                            .Style = ActiveDocument.Styles(element)
                            .Replacement.ClearFormatting
                            .Text = ""
                            .Replacement.Text = ""
                            .Forward = False
                            .Wrap = wdFindContinue
                        End With
                        Selection.Find.Execute
                        Selection.Range.ContentControls.Add (wdContentControlRichText)
                        Selection.ParentContentControl.Title = element
            Next
            '''''''''''''''''''''''''''''''''''''
            'Table 2

            Dim thearray2(1 To 8, 1 To 2)
            Dim arrWsNames2() As Variant
            arrWsNames2 = Array("Meta-ReqType", "Meta-Roles", "Meta-Input", "Meta-Output", "Meta-Toolset", _
            "Meta-Sources", "Meta-Traced", "Meta-Objective_Evidence")

            For I = 1 To 8
            thearray2(I, 1) = arrWsNames2(I - 1)
            thearray2(I, 2) = 0
            Next

            howmany = 0

            For Each element In arrWsNames2
            iterations = 1

                For Each oTbl In ActiveDocument.Tables

                oTbl.Select

                        With Selection.Find
                            .ClearFormatting
                            .Style = ActiveDocument.Styles(element)
                            .Replacement.ClearFormatting
                            .Text = ""
                            .Replacement.Text = ""
                            .Forward = False
                            .Wrap = wdFindContinue
                        End With
                        Selection.Find.Execute
                        
                        If howmany + 1 = iterations Then
                            Selection.Range.ContentControls.Add (wdContentControlRichText)
                            Selection.ParentContentControl.Title = element
                            howmany = howmany + 1
                            iterations = iterations - 1
                        Else
                        iterations = iterations + 1
                        End If
                    
                Next
                
            Next

            MsgBox ("Done")

            End Sub

If this can't be done in VBA, can it be done in .net?

Answer 1

This can definitely be done in VBA.

The first thing you need to do is to stop using the Selection object. Although there are occasions when Selection has to be used most things can be accomplished by using Range instead.

The next thing I recommend is breaking your code down into separate routines that only perform one element of the solution. This will not only enable you to simplify your code it will result in reusable routines.

I have edited your code as below and tested it in O365 on a document with a subset or your styles.

Sub AddContentControlsForMetadata()
   RemoveContentControls ActiveDocument
   Dim element As Variant
   Dim arrWsNames() As Variant
   arrWsNames = Array("Sensitive Information Protection", "Applies To", "Functional Org", "Functional Process Owner", _
      "Topic Owner", "Subject Matter Experts", "Author", "Corporate Source ID", "Superior Source", "CIPS Legacy Document", _
      "Meta-Roles(DocLvl)", "SME Reviewer", "SourceDocs", "Meta-ReqType", "Meta-Roles", "Meta-Input", "Meta-Output", "Meta-Toolset", _
      "Meta-Sources", "Meta-Traced", "Meta-Objective_Evidence")
   For Each element In arrWsNames
      FindStyleReplaceWithCC ActiveDocument, CStr(element)
   Next element
     
End Sub

Sub RemoveContentControls(docTarget As Document)
  Dim ccIndex As Long
  For ccIndex = docTarget.ContentControls.Count To 1 Step -1
     With docTarget.ContentControls(ccIndex)
        If .LockContentControl = True Then .LockContentControl = False
        .Delete False
     End With
  Next ccIndex
End Sub


Sub FindStyleReplaceWithCC(searchDoc As Document, styleName As String)
   Dim findRange As Range
   Dim ccRange As Range
   
   Set findRange = searchDoc.Range
   
   With findRange.Find
      .ClearFormatting
      .Style = ActiveDocument.Styles(styleName)
      .Replacement.ClearFormatting
      .Text = ""
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
   Do While .Execute = True
      If findRange.Information(wdWithInTable) Then
         findRange.Expand wdCell
      End If
      Set ccRange = findRange.Duplicate
      AddContentControlToRange ccRange, styleName
      'need to collapse the findRange so that Find can continue without finding the same location again
      findRange.Collapse wdCollapseEnd
   Loop
   End With
End Sub

Sub AddContentControlToRange(ByVal ccLocation As Range, ByVal ccTitle As String)
   ccLocation.ContentControls.Add(wdContentControlRichText).Title = ccTitle
End Sub

EDIT: To add both a tag and a title to the content control:

Sub AddContentControlToRange(ByVal ccLocation As Range, ByVal ccTitle As String, ByVal ccTag as String)
   With ccLocation.ContentControls.Add(wdContentControlRichText)
      .Title = ccTitle
      .Tag = ccTag
   End With
End Sub