Finding Lowest, Second Lowest, and Highest Values in an Array in PowerPoint VBA

[hunter21188]

I have assigned multiple checkboxes in a UserForm certain numbers in their respective Tag property. (i.e. 1, 2, 3, 4, etc.).

I have three shapes in a PPT slide. The user can select up to 3 checkboxes. I need the checkbox with the highest priority (i.e. number 1), to go into a specific shape. I then need the checkbox with the middle priority (i.e. number 2) to go into another shape, etc.

Here is what I have so far:



Private Sub Hazards()
Call Dictionary.HazardsDict


'References the Dictionary for the Hazard Image options.


Dim chkboxes As Variant
Dim iCtrl As Long


Select Case CountSelectedCheckBoxes(chkboxes)
Case Is > 3 'If more than three checkboxes are selected...
MsgBox "Too many selected checkboxes!" & vbCrLf & vbCrLf & "You can only select up to three hazards!", vbCritical

Case Is = 1 'If only one checkbox is selected

With ActiveWindow.Selection.SlideRange.Shapes("HazardsHeader").Fill
.Solid
.ForeColor.RGB = 192 'Sets background color of MAIN HAZARDS to dark red
End With
ActiveWindow.Selection.SlideRange.Shapes("HazardsHeader").TextFrame.TextRange.Text = "MAIN HAZARDS"


For iCtrl = LBound(chkboxes) To UBound(chkboxes)
HazardList = Array(chkboxes(iCtrl).Caption) 'Used so the For loop below can look through the dictionary and find the item that corresponds to the checkbox Caption name.
Next

For Each Ky In HazardList
ActiveWindow.Selection.SlideRange.Shapes("Hazard1").Fill.UserPicture (dict5.Item(Ky)(0))
ActiveWindow.Selection.SlideRange.Shapes("Hazard1Text").TextFrame.TextRange.Text = dict5.Item(Ky)(1)
With ActiveWindow.Selection.SlideRange.Shapes("Hazard1Text").TextFrame.TextRange.Font
.Size = 13
.Bold = msoTrue
.Color = vbBlack
End With
Next

Case Is = 2 'If exactly 2 checkboxes are selected


With ActiveWindow.Selection.SlideRange.Shapes("HazardsHeader").Fill
.Solid
.ForeColor.RGB = 192 'Sets background color of MAIN HAZARDS to dark red
End With
ActiveWindow.Selection.SlideRange.Shapes("HazardsHeader").TextFrame.TextRange.Text = "MAIN HAZARDS"


For iCtrl = LBound(chkboxes) To UBound(chkboxes)
HazardList = Array(chkboxes(iCtrl).Caption)
PriorityList = Array(chkboxes(iCtrl).Tag) 'I put the numbers from the Tag properties in an array here, but not sure how to use this.
Next


'The checkbox with the highest ranking would go in this box.
'ActiveWindow.Selection.SlideRange.Shapes("Hazard1").Fill.UserPicture (dict5.Item(Ky)(0))
'ActiveWindow.Selection.SlideRange.Shapes("Hazard1Text").TextFrame.TextRange.Text = dict5.Item(Ky)(1)

'The checkbox with the second highest ranking would go in this box
'ActiveWindow.Selection.SlideRange.Shapes("Hazard2").Fill.UserPicture (dict5.Item(Ky)(0))
'ActiveWindow.Selection.SlideRange.Shapes("Hazard2Text").TextFrame.TextRange.Text = dict5.Item(Ky)(1)
'End With
Next

End Select

Set dict5 = Nothing

End Sub


Function CountSelectedCheckBoxes(chkboxes As Variant) As Long
Dim ctrl As control
ReDim chkboxes(1 To Me.Controls.Count)


For Each ctrl In Me.Controls '<--| loop through userform controls
If TypeName(ctrl) = "CheckBox" Then '<--| check if current control is a "checkbox" one
If ctrl Then '<--| check if it's "checked"
CountSelectedCheckBoxes = CountSelectedCheckBoxes + 1 '<--| update checked checkboxes counter
Set chkboxes(CountSelectedCheckBoxes) = ctrl '<--| store it in the array
End If
End If
Next
If CountSelectedCheckBoxes > 0 Then ReDim Preserve chkboxes(1 To CountSelectedCheckBoxes) '<--|size checkboxes array to actual checked checkboxes found
End Function


The dictionary that the above code refers to looks like this:



Option Private Module 'This is necessary so that these modules do not show up in the PPT Macro window.
Public dict5 As Object, Key, val 'Makes the dictionaries public so they can be accessed by other Modules.

Sub HazardsDict()


'This is the dictionary for the Legend Images portion of the slides (only used for Slide 2 for now).


Set dict5 = CreateObject("Scripting.Dictionary")


Key = "Damaging Winds": val = Array("URL", "Damaging Winds")
dict5.Add Key, val
Key = "Large Hail": val = Array("URL", "Large Hail")
dict5.Add Key, val

End Sub



I hope this makes sense. Any help would be much appreciated! Thank you!

[John Wilson]

You should be able to bubble sort the array. Google will help but the basis of a sort is


Function SortByVal(Arrayin As Variant)
Dim b_Cont As Boolean
Dim lngCount As Long
Dim vSwap As Variant
Do
b_Cont = False
For lngCount = LBound(Arrayin) To UBound(Arrayin) - 1
If Arrayin(lngCount) > Arrayin(lngCount + 1) Then
vSwap = Arrayin(lngCount)
Arrayin(lngCount) = Arrayin(lngCount + 1)
Arrayin(lngCount + 1) = vSwap
b_Cont = True
End If
Next lngCount
Loop Until Not b_Cont
'release objects
Set vSwap = Nothing
End Function

[hunter21188]

Thanks, John.

I was able to get it to work another way. This is the method I used:


Private Sub Hazards()
Call Dictionary.HazardsDict


'References the Dictionary for the Hazard Image options.


Dim chkboxes As Variant
Dim iCtrl As Long
Dim var1 As String, var2 As String, var3 As String, t As Long
var1 = 999: var2 = 999: var3 = 999


Select Case CountSelectedCheckBoxes(chkboxes)
Case Is > 3 'If more than three checkboxes are selected...
MsgBox "Too many selected checkboxes!" & vbCrLf & vbCrLf & "You can only select up to three hazards!", vbCritical

Case Is = 3 'If exactly 3 checkboxes are selected


With ActiveWindow.Selection.SlideRange.Shapes("HazardsHeader").Fill
.Solid
.ForeColor.RGB = 192 'Sets background color of MAIN HAZARDS to dark red
End With
ActiveWindow.Selection.SlideRange.Shapes("HazardsHeader").TextFrame.TextRange.Text = "MAIN HAZARDS"

For iCtrl = LBound(chkboxes) To UBound(chkboxes)
If chkboxes(iCtrl).Value = True Then
t = CLng(chkboxes(iCtrl).Tag)
If var1 > t Then
var3 = var2
var2 = var1
var1 = t
ElseIf var2 > t Then
var3 = var2
var2 = t
ElseIf var3 > t Then
var3 = t
End If
End If
Next


ActiveWindow.Selection.SlideRange.Shapes("Hazard1").Fill.UserPicture (dict5.Item(var1)(0))
ActiveWindow.Selection.SlideRange.Shapes("Hazard1Text").TextFrame.TextRange.Text = dict5.Item(var1)(1)
With ActiveWindow.Selection.SlideRange.Shapes("Hazard1Text").TextFrame.TextRange.Font
.Size = 13
.Bold = msoTrue
.Color = vbBlack
End With
ActiveWindow.Selection.SlideRange.Shapes("Hazard2").Fill.UserPicture (dict5.Item(var2)(0))
ActiveWindow.Selection.SlideRange.Shapes("Hazard2Text").TextFrame.TextRange.Text = dict5.Item(var2)(1)
With ActiveWindow.Selection.SlideRange.Shapes("Hazard2Text").TextFrame.TextRange.Font
.Size = 13
.Bold = msoTrue
.Color = vbBlack
End With
ActiveWindow.Selection.SlideRange.Shapes("Hazard3").Fill.UserPicture (dict5.Item(var3)(0))
ActiveWindow.Selection.SlideRange.Shapes("Hazard3Text").TextFrame.TextRange.Text = dict5.Item(var3)(1)
With ActiveWindow.Selection.SlideRange.Shapes("Hazard3Text").TextFrame.TextRange.Font
.Size = 13
.Bold = msoTrue
.Color = vbBlack
End With


End Select

Set dict5 = Nothing

End Sub


Function CountSelectedCheckBoxes(chkboxes As Variant) As Long
Dim ctrl As control
ReDim chkboxes(1 To Me.Controls.Count)


For Each ctrl In Me.Controls '<--| loop through userform controls
If TypeName(ctrl) = "CheckBox" Then '<--| check if current control is a "checkbox" one
If ctrl Then '<--| check if it's "checked"
CountSelectedCheckBoxes = CountSelectedCheckBoxes + 1 '<--| update checked checkboxes counter
Set chkboxes(CountSelectedCheckBoxes) = ctrl '<--| store it in the array
End If
End If
Next
If CountSelectedCheckBoxes > 0 Then ReDim Preserve chkboxes(1 To CountSelectedCheckBoxes) '<--|size checkboxes array to actual checked checkboxes found
End Function

[John Wilson]

I was supposing there were a lot of results.