Word Macro to Count Each Value Across All Content Control's with Drop Down Lists

I have a document with multiple sections (Criteria's). Each criteria has a content control drop down with various values (with the title specific to the criteria and the tag the same for each criteria at the moment). I need a Word VBA Macro to count the total times each particular value appears across all the criteria's drop down.

Currently I am using this code to copy all the information into a table at the bottom of the document to count the value occurrences but this is very inefficient and takes some time.

Sub CriteriaCount()

'There are four parts to this macro
    '1. Set up bookmark 'CriteriaCount' at the bottom of the document and insert a table
    '2. Copy the attainment results into the table
    '3. Count the attainment results and paste values into 'Summary of Attainments' table
    '4. Remove table

'Section 1
Dim myrange As Range
Set myrange = ActiveDocument.Content

Selection.EndKey Unit:=wdStory
ActiveDocument.Bookmarks.Add "CriteriaCount"

Dim CriteriaRange As Range
Set CriteriaRange = ActiveDocument.Bookmarks("CriteriaCount").Range

myrange.Collapse Direction:=wdCollapseEnd
ActiveDocument.Tables.Add Range:=myrange, NumRows:=1, NumColumns:=1
ActiveDocument.Bookmarks.Add "CriteriaCount", CriteriaRange
ActiveDocument.Bookmarks("CriteriaCount").Select
Selection.Font.Size = 1

'Section 2
Dim i As Integer, Rng As Range
With ActiveDocument.SelectContentControlsByTag("CriteriaAttainmentRisk")
    For i = 1 To .Count
        Set Rng = .Item(i).Range
        With Rng
            .Select
            Select Case Selection.Text
                'For each case, if AR = case, go to the 'CriteriaARCount' bookmark and type the value
                Case "Not Audited": Selection.GoTo What:=wdGoToBookmark, Name:="CriteriaCount": Selection.TypeText Text:="Not Audited, "
                Case "Not Applicable": Selection.GoTo What:=wdGoToBookmark, Name:="CriteriaCount": Selection.TypeText Text:="Not Applicable, "
                Case "Pending": Selection.GoTo What:=wdGoToBookmark, Name:="CriteriaCount": Selection.TypeText Text:="Pending, "
                Case "CI": Selection.GoTo What:=wdGoToBookmark, Name:="CriteriaCount": Selection.TypeText Text:="CI, "
                Case "FA": Selection.GoTo What:=wdGoToBookmark, Name:="CriteriaCount": Selection.TypeText Text:="FA, "
                Case "PA Negligible": Selection.GoTo What:=wdGoToBookmark, Name:="CriteriaCount": Selection.TypeText Text:="PA Negligible, "
                Case "PA Low": Selection.GoTo What:=wdGoToBookmark, Name:="CriteriaCount": Selection.TypeText Text:="PA Low, "
                Case "PA Moderate": Selection.GoTo What:=wdGoToBookmark, Name:="CriteriaCount": Selection.TypeText Text:="PA Moderate, "
                Case "PA High": Selection.GoTo What:=wdGoToBookmark, Name:="CriteriaCount": Selection.TypeText Text:="PA High, "
                Case "PA Critical": Selection.GoTo What:=wdGoToBookmark, Name:="CriteriaCount": Selection.TypeText Text:="PA Critical, "
                Case "UA Negligible": Selection.GoTo What:=wdGoToBookmark, Name:="CriteriaCount": Selection.TypeText Text:="UA Negligible, "
                Case "UA Low": Selection.GoTo What:=wdGoToBookmark, Name:="CriteriaCount": Selection.TypeText Text:="UA Low, "
                Case "UA Moderate": Selection.GoTo What:=wdGoToBookmark, Name:="CriteriaCount": Selection.TypeText Text:="UA Moderate, "
                Case "UA High": Selection.GoTo What:=wdGoToBookmark, Name:="CriteriaCount": Selection.TypeText Text:="UA High, "
                Case "UA Critical": Selection.GoTo What:=wdGoToBookmark, Name:="CriteriaCount": Selection.TypeText Text:="UA Critical, "
            End Select
        End With
    Next
End With

'Section 3
Dim CriteriaSearchNotAudited As String, CriteriaSearchNotApplicable As String, CriteriaSearchPending As String, CriteriaSearchCI As String, CriteriaSearchFA As String
Dim CriteriaSearchPAN As String, CriteriaSearchPAL As String, CriteriaSearchPAM As String, CriteriaSearchPAH As String, CriteriaSearchPAC As String
Dim CriteriaSearchUAN As String, CriteriaSearchUAL As String, CriteriaSearchUAM As String, CriteriaSearchUAH As String, CriteriaSearchUAC As String

Dim CriteriaCountNotAudited As Integer, CriteriaCountNotApplicable As Integer, CriteriaCountPending As Integer, CriteriaCountCI As Integer, CriteriaCountFA As Integer
Dim CriteriaCountPAN As Integer, CriteriaCountPAL As Integer, CriteriaCountPAM As Integer, CriteriaCountPAH As Integer, CriteriaCountPAC As Integer
Dim CriteriaCountUAN As Integer, CriteriaCountUAL As Integer, CriteriaCountUAM As Integer, CriteriaCountUAH As Integer, CriteriaCountUAC As Integer

CriteriaSearchNotAudited = "Not Audited" 'Count Not Audited
    With ActiveDocument.Bookmarks("CriteriaCount").Range.Find: .Text = CriteriaSearchNotAudited: .Format = False: .Wrap = wdFindStop
    Do While .Execute: CriteriaCountNotAudited = CriteriaCountNotAudited + 1: Loop: End With
    ActiveDocument.SelectContentControlsByTitle("CriteriaNotAudited").Item(1).Range.Select: Selection.TypeText CriteriaCountNotAudited

CriteriaSearchNotApplicable = "Not Applicable" 'Count Not Applicable
    With ActiveDocument.Bookmarks("CriteriaCount").Range.Find: .Text = CriteriaSearchNotApplicable: .Format = False: .Wrap = wdFindStop
    Do While .Execute: CriteriaCountNotApplicable = CriteriaCountNotApplicable + 1: Loop: End With
    ActiveDocument.SelectContentControlsByTitle("CriteriaNotApplicable").Item(1).Range.Select: Selection.TypeText CriteriaCountNotApplicable

CriteriaSearchPending = "Pending" 'Count Pending
    With ActiveDocument.Bookmarks("CriteriaCount").Range.Find: .Text = CriteriaSearchPending: .Format = False: .Wrap = wdFindStop
    Do While .Execute: CriteriaCountPending = CriteriaCountPending + 1: Loop: End With
    ActiveDocument.SelectContentControlsByTitle("CriteriaPending").Item(1).Range.Select: Selection.TypeText CriteriaCountPending

CriteriaSearchCI = "CI" 'Count CI
    With ActiveDocument.Bookmarks("CriteriaCount").Range.Find: .Text = CriteriaSearchCI: .Format = False: .Wrap = wdFindStop:
    Do While .Execute: CriteriaCountCI = CriteriaCountCI + 1: Loop: End With
    ActiveDocument.SelectContentControlsByTitle("CriteriaCI").Item(1).Range.Select: Selection.TypeText CriteriaCountCI

CriteriaSearchFA = "FA" 'Count FA
    With ActiveDocument.Bookmarks("CriteriaCount").Range.Find: .Text = CriteriaSearchFA: .Format = False: .Wrap = wdFindStop
    Do While .Execute: CriteriaCountFA = CriteriaCountFA + 1: Loop: End With
    ActiveDocument.SelectContentControlsByTitle("CriteriaFA").Item(1).Range.Select: Selection.TypeText CriteriaCountFA

CriteriaSearchPAN = "PA Negligible" 'Count PA Negligible
    With ActiveDocument.Bookmarks("CriteriaCount").Range.Find: .Text = CriteriaSearchPAN: .Format = False: .Wrap = wdFindStop
    Do While .Execute: CriteriaCountPAN = CriteriaCountPAN + 1: Loop: End With
    ActiveDocument.SelectContentControlsByTitle("CriteriaPANegligible").Item(1).Range.Select: Selection.TypeText CriteriaCountPAN

CriteriaSearchPAL = "PA Low" 'Count PA Low
    With ActiveDocument.Bookmarks("CriteriaCount").Range.Find: .Text = CriteriaSearchPAL: .Format = False: .Wrap = wdFindStop
    Do While .Execute: CriteriaCountPAL = CriteriaCountPAL + 1: Loop: End With
    ActiveDocument.SelectContentControlsByTitle("CriteriaPALow").Item(1).Range.Select: Selection.TypeText CriteriaCountPAL

CriteriaSearchPAM = "PA Moderate" 'Count PA Moderate
    With ActiveDocument.Bookmarks("CriteriaCount").Range.Find: .Text = CriteriaSearchPAM: .Format = False: .Wrap = wdFindStop
    Do While .Execute: CriteriaCountPAM = CriteriaCountPAM + 1: Loop: End With
    ActiveDocument.SelectContentControlsByTitle("CriteriaPAModerate").Item(1).Range.Select: Selection.TypeText CriteriaCountPAM

CriteriaSearchPAH = "PA High" 'Count PA High
    With ActiveDocument.Bookmarks("CriteriaCount").Range.Find: .Text = CriteriaSearchPAH: .Format = False: .Wrap = wdFindStop
    Do While .Execute: CriteriaCountPAH = CriteriaCountPAH + 1: Loop: End With
    ActiveDocument.SelectContentControlsByTitle("CriteriaPAHigh").Item(1).Range.Select: Selection.TypeText CriteriaCountPAH

CriteriaSearchPAC = "PA Critical" 'Count PA Critical
    With ActiveDocument.Bookmarks("CriteriaCount").Range.Find: .Text = CriteriaSearchPAC: .Format = False: .Wrap = wdFindStop
    Do While .Execute: CriteriaCountPAC = CriteriaCountPAC + 1: Loop: End With
    ActiveDocument.SelectContentControlsByTitle("CriteriaPACritical").Item(1).Range.Select: Selection.TypeText CriteriaCountPAC

CriteriaSearchUAN = "UA Negligible" 'Count UA Negligible
    With ActiveDocument.Bookmarks("CriteriaCount").Range.Find: .Text = CriteriaSearchUAN: .Format = False: .Wrap = wdFindStop
    Do While .Execute: CriteriaCountUAN = CriteriaCountUAN + 1: Loop: End With
    ActiveDocument.SelectContentControlsByTitle("CriteriaUANegligible").Item(1).Range.Select: Selection.TypeText CriteriaCountUAN

CriteriaSearchUAL = "UA Low" 'Count UA Low
    With ActiveDocument.Bookmarks("CriteriaCount").Range.Find: .Text = CriteriaSearchUAL: .Format = False: .Wrap = wdFindStop
    Do While .Execute: CriteriaCountUAL = CriteriaCountUAL + 1: Loop: End With
    ActiveDocument.SelectContentControlsByTitle("CriteriaUALow").Item(1).Range.Select: Selection.TypeText CriteriaCountUAL

CriteriaSearchUAM = "UA Moderate" 'Count UA Moderate
    With ActiveDocument.Bookmarks("CriteriaCount").Range.Find: .Text = CriteriaSearchUAM: .Format = False: .Wrap = wdFindStop
    Do While .Execute: CriteriaCountUAM = CriteriaCountUAM + 1: Loop: End With
    ActiveDocument.SelectContentControlsByTitle("CriteriaUAModerate").Item(1).Range.Select: Selection.TypeText CriteriaCountUAM

CriteriaSearchUAH = "UA High" 'Count UA High
    With ActiveDocument.Bookmarks("CriteriaCount").Range.Find: .Text = CriteriaSearchUAH: .Format = False: .Wrap = wdFindStop
    Do While .Execute: CriteriaCountUAH = CriteriaCountUAH + 1: Loop: End With
    ActiveDocument.SelectContentControlsByTitle("CriteriaUAHigh").Item(1).Range.Select: Selection.TypeText CriteriaCountUAH

CriteriaSearchUAC = "UA Critical" 'Count UA Critical
    With ActiveDocument.Bookmarks("CriteriaCount").Range.Find: .Text = CriteriaSearchUAC: .Format = False: .Wrap = wdFindStop
    Do While .Execute: CriteriaCountUAC = CriteriaCountUAC + 1: Loop: End With
    ActiveDocument.SelectContentControlsByTitle("CriteriaUACritical").Item(1).Range.Select: Selection.TypeText CriteriaCountUAC

'Section 4 - delete table/bookmark
ActiveDocument.Bookmarks("CriteriaCount").Range.Tables(1).Select
Selection.Rows.Delete
ActiveDocument.Bookmarks("CriteriaCount").Delete

End Sub

Select allOpen in new window

What can I do to make this work?