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.