Counting Instances of a Dropdown List Value

[karoloydi]

Hi,

I have 30 dropdown lists on my document. Each List Has 10 different options (red, blue, pink, green, etc.)

I want to make a code that goes through the document and calculates the total of times each color has been selected on all of the 30 lists.

I ve been trying to find someone witha similar question to me fo rhours now with no luck. I appreciate your help.

[gmaxey]

Assuming the dropdowns are ContentControls then something like this:


Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey, http://gregmaxey.com/word_tips.html, 9/9/2017
Dim oCC As ContentControl
Dim lngIndex As Long
Dim lngCount As Long
Dim arrColors() As String
lngCount = ActiveDocument.ContentControls.Count
ReDim arrColors(1 To lngCount)
For lngIndex = 1 To ActiveDocument.ContentControls.Count
arrColors(lngIndex) = ActiveDocument.ContentControls(lngIndex).Range.Text
Next
MsgBox UBound(Filter(arrColors, "Blue")) + 1
MsgBox UBound(Filter(arrColors, "Red")) + 1
MsgBox UBound(Filter(arrColors, "Pink")) + 1
MsgBox UBound(Filter(arrColors, "Green")) + 1
lbl_Exit:
Exit Sub
End Sub

[karoloydi]

Thank you. The concept works. But what I really want is to automatically update a form in the document.
I want to have a table in the bottom of the document that says:

Blue:
Red:
Green:
Pink:

SO I think I need to change this part from MsgBox to InsertText and DisplayText (sorry, I'm clueless):


MsgBox UBound(Filter(arrColors, "Blue")) + 1
MsgBox UBound(Filter(arrColors, "Red")) + 1
MsgBox UBound(Filter(arrColors, "Pink")) + 1
MsgBox UBound(Filter(arrColors, "Green")) + 1

And then the fields are automatically updated, or at least to be updated when I press a shortcut or even better a button or something similar to that.
I think I can create a macro button for that, is that correct?

It would be great if you could show me how to do that.

[gmayor]

With a little modification and a change of direction you can update the count automatically by using the content control on exit event

Put the following code in the document's ThisDocument module. Put a bookmark at the end of each row of your table i.e. bmBlue, bmRed, bmGreen, bmPink as appropriate and then as the items are selected and you click outside the fields the colour count is updated. (see attached)


Option Explicit

Private Sub Document_ContentControlOnExit(ByVal ContentControl As ContentControl, Cancel As Boolean)
Dim lngIndex As Long
Dim lngCount As Long
Dim arrColors() As String
lngCount = ActiveDocument.ContentControls.Count
ReDim arrColors(1 To lngCount)
For lngIndex = 1 To ActiveDocument.ContentControls.Count
arrColors(lngIndex) = ActiveDocument.ContentControls(lngIndex).Range.Text
Next
FillBM "bmBlue", UBound(Filter(arrColors, "Blue")) + 1
FillBM "bmRed", UBound(Filter(arrColors, "Red")) + 1
FillBM "bmGreen", UBound(Filter(arrColors, "Pink")) + 1
FillBM "bmPink", UBound(Filter(arrColors, "Green")) + 1
lbl_Exit:
Exit Sub
End Sub


Private Sub FillBM(strbmName As String, strValue As String)
'Graham Mayor - http://www.gmayor.com
Dim oRng As Range
With ActiveDocument
On Error GoTo lbl_Exit
Set oRng = .Bookmarks(strbmName).Range
oRng.Text = strValue
oRng.Bookmarks.Add strbmName
End With
lbl_Exit:
Set oRng = Nothing
Exit Sub
End Sub

[karoloydi]

Thank you! That's amazing. I have 2 problems.

One problem is that whenever I run the file for the first time and also other times randomly I can't select any option on the droplist for about 2-3 minutes. It keeps loading something. Is it possible to search only for the droplist with specific title instead of looking in the whole document? Maybe that will help.

Second problem, when I try to combine it with the following code it is giving me error
"Ambiguous Name Detected Document Content Control On Exit"
I am placing the following code at the end of the code you gave me



Private Sub Document_ContentControlOnExit(ByVal ContentControl As ContentControl, Cancel As Boolean)
Dim i As Long, StrDetails As String
With ContentControl
Select Case .Title
Case Is = "Planner"
For i = 1 To .DropdownListEntries.Count
If .DropdownListEntries(i).Text = .Range.Text Then
StrDetails = Replace(.DropdownListEntries(i).Value, "|", Chr(11))
Exit For
End If
Next
ActiveDocument.SelectContentControlsByTag("Planner").Item(1).Range.Text = StrDetails
Case Else
End Select
End With
End Sub

[karoloydi]

That's the complete code I'm trying to use.

Option Explicit

Private Sub Document_ContentControlOnExit(ByVal ContentControl As ContentControl, Cancel As Boolean)
Dim lngIndex As Long
Dim lngCount As Long
Dim arrColors() As String
lngCount = ActiveDocument.ContentControls.Count
ReDim arrColors(1 To lngCount)
For lngIndex = 1 To ActiveDocument.ContentControls.Count
arrColors(lngIndex) = ActiveDocument.ContentControls(lngIndex).Range.Text
Next
FillBM "bmAccident", UBound(Filter(arrColors, "Accident Report")) + 1
FillBM "bmBalcony", UBound(Filter(arrColors, "Balcony")) + 1
FillBM "bmDoorLock", UBound(Filter(arrColors, "Door Lock")) + 1
FillBM "bmIncident", UBound(Filter(arrColors, "Incident Report")) + 1
FillBM "bmKeyFault", UBound(Filter(arrColors, "Key Fault")) + 1
FillBM "bmLostFoundLogged", UBound(Filter(arrColors, "L & F Logged")) + 1
FillBM "bmLostFoundReturned", UBound(Filter(arrColors, "L & F Returned")) + 1
FillBM "bmLockRead", UBound(Filter(arrColors, "Lock Read")) + 1
FillBM "bmSafe", UBound(Filter(arrColors, "Safe")) + 1
FillBM "bmTheft", UBound(Filter(arrColors, "Theft Allegation")) + 1
FillBM "bmEscort", UBound(Filter(arrColors, "Escort")) + 1
FillBM "bmIDCheck", UBound(Filter(arrColors, "ID Check")) + 1
lbl_Exit:

End Sub




Private Sub FillBM(strbmName As String, strValue As String)

Dim oRng As Range
With ActiveDocument
On Error GoTo lbl_Exit
Set oRng = .Bookmarks(strbmName).Range
oRng.Text = strValue
oRng.Bookmarks.Add strbmName
End With
lbl_Exit:
Set oRng = Nothing
Exit Sub
End Sub


Private Sub Document_ContentControlOnExit(ByVal ContentControl As ContentControl, Cancel As Boolean)
Dim i As Long, StrDetails As String
With ContentControl
Select Case .Title
Case Is = "Planner"
For i = 1 To .DropdownListEntries.Count
If .DropdownListEntries(i).Text = .Range.Text Then
StrDetails = Replace(.DropdownListEntries(i).Value, "|", Chr(11))
Exit For
End If
Next
ActiveDocument.SelectContentControlsByTag("Planner").Item(1).Range.Text = StrDetails
Case Else
End Select
End With
End Sub

[gmaxey]

You keep moving the goal post after the start of the game!

You will have to define something unique about the 30 CCs out of X total in the document that figure in the tally. E.g., you could tag them with "ColorCC"

"Ambiguous Name" no surprise there. You can't have two procedures in the same module with the same name.

If you want to write to a table as you indicated after the first goal post move then something like;



Option Explicit
Private oTbl As Table
Private lngColorCCCount As Long
Sub Document_Open()
lngColorCCCount = ActiveDocument.SelectContentControlsByTag("ColorCC").Count
End Sub
Sub Document_New()
lngColorCCCount = ActiveDocument.SelectContentControlsByTag("ColorCC").Count
End Sub
Private Sub Document_ContentControlOnExit(ByVal oCC As ContentControl, Cancel As Boolean)
Dim lngIndex As Long
Dim arrColors() As String
Dim strDetails As String
Select Case oCC.Tag
Case "ColorCC"
Set oTbl = ActiveDocument.Tables(1) 'or whatever table it is.
ReDim arrColors(1 To lngColorCCCount)
For lngIndex = 1 To ActiveDocument.SelectContentControlsByTag("ColorCC").Count
arrColors(lngIndex) = ActiveDocument.SelectContentControlsByTag("ColorCC").Item(lngIndex).Range.Text
Next
'Fills x row, 2 column table with value in column 2.
FillTable 1, UBound(Filter(arrColors, "Blue")) + 1
FillTable 2, UBound(Filter(arrColors, "Red")) + 1
FillTable 3, UBound(Filter(arrColors, "Pink")) + 1
FillTable 4, UBound(Filter(arrColors, "Green")) + 1
Case Else
Select Case oCC.Title
Case "Planner"
With oCC
For lngIndex = 1 To .DropdownListEntries.Count
If .DropdownListEntries(lngIndex).Text = .Range.Text Then
strDetails = Replace(.DropdownListEntries(lngIndex).Value, "|", Chr(11))
Exit For
End If
Next
.Type = wdContentControlText
.Range.Text = strDetails
.Type = wdContentControlDropdownList
End With
Case Else
End Select
End Select
lbl_Exit:
Set oTbl = Nothing
Exit Sub
End Sub
Sub FillTable(lngRow As Long, strValue As String)
oTbl.Cell(lngRow, 2).Range.Text = strValue
End Sub

[macropod]

Cross-posted at: https://windowssecrets.com/forums/showthread.php/186371-Counting-Instances-of-a-Dropdown-List-Value
Please read VBA Express' policy on Cross-Posting in item 3 of the rules: http://www.vbaexpress.com/forum/faq.php?faq=new_faq_item#faq_new_faq_item3

[gmaxey]

Paul,

Thanks. At least this hasn't been a complete waste of Graham's and my time.

[karoloydi]

Thank you guyz. It works now

[tgamekh]

Assuming the dropdowns are ContentControls then something like this:


Sub ScratchMacro()
Dim oCC As ContentControl
Dim lngIndex As Long
Dim lngCount As Long
Dim arrColors() As String
lngCount = ActiveDocument.ContentControls.Count
ReDim arrColors(1 To lngCount)
For lngIndex = 1 To ActiveDocument.ContentControls.Count
arrColors(lngIndex) = ActiveDocument.ContentControls(lngIndex).Range.Text
Next
MsgBox UBound(Filter(arrColors, "Blue")) + 1
MsgBox UBound(Filter(arrColors, "Red")) + 1
MsgBox UBound(Filter(arrColors, "Pink")) + 1
MsgBox UBound(Filter(arrColors, "Green")) + 1
lbl_Exit:
Exit Sub
End Sub




Hello,

Is there a way to combine all of the results from the above code into one MsgBox with each result listed on it's own line?

Something along the lines of:

Blue = 3
Red = 4
Pink = 1
Green = 5


Thank you!

[macropod]

That's pretty basic VBA code, really...

MsgBox _
"Blue: " & UBound(Filter(arrColors, "Blue")) + 1 & vbCr & _
"Red: " & UBound(Filter(arrColors, "Red")) + 1 & vbCr & _
"Pink: " & UBound(Filter(arrColors, "Pink")) + 1 & vbCr & _
"Green: " & UBound(Filter(arrColors, "Green")) + 1

[tgamekh]

That's pretty basic VBA code, really...

MsgBox _
"Blue: " & UBound(Filter(arrColors, "Blue")) + 1 & vbCr & _
"Red: " & UBound(Filter(arrColors, "Red")) + 1 & vbCr & _
"Pink: " & UBound(Filter(arrColors, "Pink")) + 1 & vbCr & _
"Green: " & UBound(Filter(arrColors, "Green")) + 1


Thank you. I am still starting out and find that I am biting off bigger projects than I can sometimes chew. Your help is greatly appreciated.