Excel滑块控件：如何将所有滑块的总和限制为100？

Question

为清晰起见，请参阅图片。

我有5个变量（A，B，C，D和E），每个变量的范围可以是0-100。我需要所有这些变量的 sum 始终为100，而不是更多，而不是更少。但是，当前设置的方式，如果我将变量A从21更改为51，则总计变为130.

我如何设置它，以便如果我更改一个变量，其他变量可以自动补偿该增加或减少，这样总数总是 100？

Answer 1

使用滑块更改事件，以便当一个滑块更改值时，其他滑块会缩放，因此值总和为100

示例代码，使用3个滑块 - 您可以缩放它以允许任意数量的滑块

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

请注意，滑块数据类型为整数，因此您可能需要允许舍入而不是求和到100

Answer 2

Thx Chris发布了您的解决方案。要将其缩放到六个，我做到了。我不是VBA专家，此代码还不是很干净或很棒。但这可能会帮助某人。

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