Excel Slider Control: How could I limit the sum of all sliders to, say, 100?

See image for clarity.

I have 5 variables (A, B, C, D and E), each of which can range from 0-100. I need the sum of all these variables to be 100 at all times, not more, not less. However, the way it开发者_Go百科 is set up currently, if I change variable A from 21 to, say, 51, the total becomes 130.

How could I set this up such that if I change one variable, the others could automatically compensate for that increase or decrease, such that the total is always 100?

---

Use the Slider Change events, so that when one slider changes value the others are scaled so values sum to 100

Example code, using 3 sliders - you can scale it to allow for as many sliders as you want

Private UpdateSlider As Boolean

Private Sub ScaleSliders(slA As Double, ByRef slB As Double, ByRef slC As Double)
    Dim ScaleFactor As Double
    If (slB + slC) = 0 Then
        ScaleFactor = (100# - slA)
        slB = ScaleFactor / 2
        slC = ScaleFactor / 2

    Else
        ScaleFactor = (100# - slA) / (slB + slC)

        slB = slB * ScaleFactor
        slC = slC * ScaleFactor
    End If
End Sub


Private Sub ScrollBar1_Change()
    Dim slB As Double, slC As Double
   ' UpdateSlider = False
    If Not UpdateSlider Then
        slB = ScrollBar2.Value
        slC = ScrollBar3.Value
        ScaleSliders ScrollBar1.Value, slB, slC
        UpdateSlider = True
        ScrollBar2.Value = slB
        ScrollBar3.Value = slC
        UpdateSlider = False
    End If
End Sub

Private Sub ScrollBar2_Change()
    Dim slB As Double, slC As Double
    If Not UpdateSlider Then
        slB = ScrollBar1.Value
        slC = ScrollBar3.Value
        ScaleSliders ScrollBar2.Value, slB, slC
        UpdateSlider = True
        ScrollBar1.Value = slB
        ScrollBar3.Value = slC
        UpdateSlider = False
    End If
End Sub

Private Sub ScrollBar3_Change()
    Dim slB As Double, slC As Double
    If Not UpdateSlider Then
        slB = ScrollBar1.Value
        slC = ScrollBar2.Value
        ScaleSliders ScrollBar1.Value, slB, slC
        UpdateSlider = True
        ScrollBar1.Value = slB
        ScrollBar2.Value = slC
        UpdateSlider = False
    End If
End Sub

Note that sliders data type in integer, so you may need to allow for rounding not summing to exactly 100

---

Thx Chris for posting your solution. To scale it to six, I've made this. I'm no VBA expert, this code is not yet really clean or great. but it might help someone.

Private UpdateSlider As Boolean

Private Sub ScaleSliders_arr(slider_value As Double, ByRef other_sliders() As Double)
    Dim scale_factor As Double
    Dim total_other_sliders As Double
    Dim element As Variant
    Dim i As Integer
    Dim other_sliders_arr_length As Long
    
    For Each element In other_sliders
        total_other_sliders = total_other_sliders + element
        Debug.Print total_other_sliders
    Next element
    
    ' when all other values are 0
    If total_other_sliders = 0 Then
        ScaleFactor = (100# - slider_value)
        
        other_sliders_arr_length = ArrayLength(other_sliders)
        
        i = 0
        For Each element In other_sliders
            other_sliders(i) = ScaleFactor / other_sliders_arr_length
            i = i + 1
        Next element

        Debug.Print other_sliders_arr_length
    
    ' When other sliders have >0 as a total sum
    Else

        ScaleFactor = (100# - slider_value) / total_other_sliders
        ' Adjust other sliders according to current value
        i = 0
        For Each element In other_sliders
            other_sliders(i) = other_sliders(i) * ScaleFactor
            i = i + 1
        Next element

    End If
End Sub


Private Sub AdjustSliderByMagic(this_slider As Variant)
    Dim slider_value As Double
    Dim other_sliders() As Double
    Dim cell_locations() As Variant
    Dim other_sliders_arr_size As Integer
    Dim value As Variant
    Dim i As Integer
    Dim k As Integer
    
    ' which cells contain the values - this also determines number of rows
    cell_locations = Array("HiddenTable!B2", "HiddenTable!B3", "HiddenTable!B4", "HiddenTable!B5", "HiddenTable!B6", "HiddenTable!B7")
    
    ' size of the others is minus 2 because A) counting starts at 0 B) one slider is the current one which is not the other
    other_sliders_arr_size = ArrayLength(cell_locations) - 2
    
    ' need to size the other sliders array
    ReDim other_sliders(other_sliders_arr_size)
    
    ' start loops with 0's
    i = 0
    k = 0
    
    ' Determine the value of this slider and of the other sliders
    For Each value In cell_locations
        If this_slider = cell_locations(i) Then
            slider_value = Range(cell_locations(i)).value
            
        Else
            other_sliders(k) = Range(cell_locations(i)).value
            k = k + 1
        End If
        
        i = i + 1
    Next value
    
    ' use function to determine slider values
    ScaleSliders_arr slider_value, other_sliders
    
    UpdateSlider = True
    
    
    ' start loops with 0's
    i = 0
    k = 0
    
    ' change the values of the other sliders
    For Each value In cell_locations
        If this_slider = cell_locations(i) Then
            'do nothing
        Else
            Range(cell_locations(i)).value = other_sliders(k)
            k = k + 1
        End If
        
        i = i + 1
    Next value


End Sub

Private Sub ScrollBar1_Change()
    Dim this_slider As Variant
    
    ' what is the connected field of this slider
    this_slider = "HiddenTable!B2"
    
    AdjustSliderByMagic (this_slider)
    
End Sub


Private Sub ScrollBar2_Change()
    Dim this_slider As Variant
    
    ' what is the connected field of this slider
    this_slider = "HiddenTable!B3"
    
    AdjustSliderByMagic (this_slider)
    
End Sub

Private Sub ScrollBar3_Change()
    Dim this_slider As Variant
    
    ' what is the connected field of this slider
    this_slider = "HiddenTable!B4"
    
    AdjustSliderByMagic (this_slider)
    
End Sub
Private Sub ScrollBar4_Change()
    Dim this_slider As Variant
    
    ' what is the connected field of this slider
    this_slider = "HiddenTable!B5"
    
    AdjustSliderByMagic (this_slider)
    
End Sub
Private Sub ScrollBar5_Change()
    Dim this_slider As Variant
    
    ' what is the connected field of this slider
    this_slider = "HiddenTable!B6"
    
    AdjustSliderByMagic (this_slider)
    
End Sub
Private Sub ScrollBar6_Change()
    Dim this_slider As Variant
    
    ' what is the connected field of this slider
    this_slider = "HiddenTable!B7"
    
    AdjustSliderByMagic (this_slider)
    
End Sub


Function ArrayLength(arr As Variant) As Long

    On Error GoTo eh
    
    ' Loop is used for multidimensional arrays. The Loop will terminate when a
    ' "Subscript out of Range" error occurs i.e. there are no more dimensions.
    Dim i As Long, length As Long
    length = 1
    
    ' Loop until no more dimensions
    Do While True
        i = i + 1
        ' If the array has no items then this line will throw an error
        length = length * (UBound(arr, i) - LBound(arr, i) + 1)
        ' Set ArrayLength here to avoid returing 1 for an empty array
        ArrayLength = length
    Loop

Done:
    Exit Function
eh:
    If Err.Number = 13 Then ' Type Mismatch Error
        Err.Raise vbObjectError, "ArrayLength" _
            , "The argument passed to the ArrayLength function is not an array."
    End If
End Function