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

Open in new window


What can I do to make this work?
BAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Rgonzo1971Commented:
Hi,

pls try
Sub CriteriaCount()

Dim myrange As Range
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

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": CriteriaCountNotAudited = CriteriaCountNotAudited + 1
                Case "Not Applicable": CriteriaCountNotApplicable = CriteriaCountNotApplicable + 1
                Case "Pending": CriteriaCountPending = CriteriaCountPending + 1
                Case "CI": CriteriaCountCI = CriteriaCountCI + 1
                Case "FA": CriteriaCountFA = CriteriaCountFA + 1
                Case "PA Negligible": CriteriaCountPAN = CriteriaCountPAN + 1
                Case "PA Low": CriteriaCountPAL = CriteriaCountPAL + 1
                Case "PA Moderate": CriteriaCountPAM = CriteriaCountPAM + 1
                Case "PA High": CriteriaCountPAH = CriteriaCountPAH + 11
                Case "PA Critical": CriteriaCountPAC = CriteriaCountPAC + 1
                Case "UA Negligible": CriteriaCountUAN = CriteriaCountUAN + 1
                Case "UA Low": CriteriaCountUAL = CriteriaCountUAL + 1
                Case "UA Moderate": CriteriaCountUAM = CriteriaCountUAM + 1
                Case "UA High": CriteriaCountUAH = CriteriaCountUAH + 1
                Case "UA Critical": CriteriaCountUAC = CriteriaCountUAC + 1
            End Select
        End With
    Next
End With

ActiveDocument.SelectContentControlsByTitle("CriteriaNotAudited").Item(1).Range.Select: Selection.TypeText CriteriaCountNotAudited
ActiveDocument.SelectContentControlsByTitle("CriteriaNotApplicable").Item(1).Range.Select: Selection.TypeText CriteriaCountNotApplicable
ActiveDocument.SelectContentControlsByTitle("CriteriaPending").Item(1).Range.Select: Selection.TypeText CriteriaCountPending
ActiveDocument.SelectContentControlsByTitle("CriteriaCI").Item(1).Range.Select: Selection.TypeText CriteriaCountCI
ActiveDocument.SelectContentControlsByTitle("CriteriaFA").Item(1).Range.Select: Selection.TypeText CriteriaCountFA
ActiveDocument.SelectContentControlsByTitle("CriteriaPANegligible").Item(1).Range.Select: Selection.TypeText CriteriaCountPAN
ActiveDocument.SelectContentControlsByTitle("CriteriaPALow").Item(1).Range.Select: Selection.TypeText CriteriaCountPAL
ActiveDocument.SelectContentControlsByTitle("CriteriaPAModerate").Item(1).Range.Select: Selection.TypeText CriteriaCountPAM
ActiveDocument.SelectContentControlsByTitle("CriteriaPAHigh").Item(1).Range.Select: Selection.TypeText CriteriaCountPAH
ActiveDocument.SelectContentControlsByTitle("CriteriaPACritical").Item(1).Range.Select: Selection.TypeText CriteriaCountPAC
ActiveDocument.SelectContentControlsByTitle("CriteriaUANegligible").Item(1).Range.Select: Selection.TypeText CriteriaCountUAN
ActiveDocument.SelectContentControlsByTitle("CriteriaUALow").Item(1).Range.Select: Selection.TypeText CriteriaCountUAL
ActiveDocument.SelectContentControlsByTitle("CriteriaUAModerate").Item(1).Range.Select: Selection.TypeText CriteriaCountUAM
ActiveDocument.SelectContentControlsByTitle("CriteriaUAHigh").Item(1).Range.Select: Selection.TypeText CriteriaCountUAH
ActiveDocument.SelectContentControlsByTitle("CriteriaUACritical").Item(1).Range.Select: Selection.TypeText CriteriaCountUAC

End Sub

Open in new window

Regards
1

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Rgonzo1971Commented:
A solution
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VBA

From novice to tech pro — start learning today.