VBA - 自动选择正确和四舍五入的比例

Question

我有挣扎。我有一个运行良好的代码，但我必须在代码中设置我自己的范围(比例(，如您所见(cato0 到 cato 8(。我的代码必须在各种数据(货币(上运行，可能是数百万，可能是K。但必须四舍五入以达到完美的明显比例。如果有人有想法，我迫不及待地想听听你对此事的看法......

sub test()
  Dim Cato0 As Double, Cato1 As Double, Cato2 As Double, Cato3 As Double, Cato4 As Double, _
        Cato5 As Double, Cato6 As Double, Cato7 As Double, Cato8 As Double, Cato9 As String
    Cato0 = 0
    Cato1 = 500
    Cato2 = 1000
    Cato3 = 2500
    Cato4 = 5000
    Cato5 = 7500
    Cato6 = 10000
    Cato7 = 12500
    Cato8 = 15000
    Dim TargetRange         As Range
    Dim TotalPremium()      As Double
    Dim PremiumCount()      As Long
    Dim TotalCommission()   As Double
    Dim CellPremium()       As Double
    Dim PolNo               As Long
    Dim Cell                As Range
    Dim NOCatoI             As Integer
    NOCatoI = 9 'Number of Catogories
    PolNo = 1
    ReDim PremiumCount(1 To NOCatoI)
    ReDim TotalPremium(1 To NOCatoI)
    ReDim TotalCommission(1 To NOCatoI)

    With ThisWorkbook.Sheets("Sheet3")
        lastRow = .Cells(Rows.Count, 2).End(xlUp).Row
        LastColumn = .Cells(1, Columns.Count).End(xlToLeft).Column
        'Set TargetRange = Range("CC2:CC" & lastRow)
    End With
    Set TargetRange = ThisWorkbook.Sheets("Sheet3").Range("CC2:CC" & lastRow)
    For Each Cell In TargetRange
        With Cell
            If .Value <= Cato1 Then
                i = 1
                TotalPremium(i) = TotalPremium(i) + .Value
                PremiumCount(i) = PremiumCount(i) + 1
                TotalCommission(i) = TotalCommission(i) + .Offset(0, 3).Value
            ElseIf (.Value > Cato1) And (.Value <= Cato2) Then
                i = 2
                TotalPremium(i) = TotalPremium(i) + .Value
                PremiumCount(i) = PremiumCount(i) + 1
                TotalCommission(i) = TotalCommission(i) + .Offset(0, 3).Value
           ElseIf (.Value > Cato2) And (.Value <= Cato3) Then
                i = 3
                TotalPremium(i) = TotalPremium(i) + .Value
                PremiumCount(i) = PremiumCount(i) + 1
                TotalCommission(i) = TotalCommission(i) + .Offset(0, 3).Value
           ElseIf (.Value > Cato3) And (.Value <= Cato4) Then
                i = 4
                TotalPremium(i) = TotalPremium(i) + .Value
                PremiumCount(i) = PremiumCount(i) + 1
                TotalCommission(i) = TotalCommission(i) + .Offset(0, 3).Value
            ElseIf (.Value > Cato4) And (.Value <= Cato5) Then
                i = 5
                TotalPremium(i) = TotalPremium(i) + .Value
                PremiumCount(i) = PremiumCount(i) + 1
                TotalCommission(i) = TotalCommission(i) + .Offset(0, 3).Value
            ElseIf (.Value > Cato5) And (.Value <= Cato6) Then
                i = 6
                TotalPremium(i) = TotalPremium(i) + .Value
                PremiumCount(i) = PremiumCount(i) + 1
                TotalCommission(i) = TotalCommission(i) + .Offset(0, 3).Value
            ElseIf (.Value > Cato6) And (.Value <= Cato7) Then
                i = 7
                TotalPremium(i) = TotalPremium(i) + .Value
                PremiumCount(i) = PremiumCount(i) + 1
                TotalCommission(i) = TotalCommission(i) + .Offset(0, 3).Value
            ElseIf (.Value > Cato7) And (.Value <= Cato8) Then
                i = 8
                TotalPremium(i) = TotalPremium(i) + .Value
                PremiumCount(i) = PremiumCount(i) + 1
                TotalCommission(i) = TotalCommission(i) + .Offset(0, 3).Value
            ElseIf Cato8 < .Value Then
                i = 9
                TotalPremium(i) = TotalPremium(i) + .Value
                PremiumCount(i) = PremiumCount(i) + 1
                TotalCommission(i) = TotalCommission(i) + .Offset(0, 3).Value
            End If
        End With
    Next
    With ThisWorkbook.Sheets("sheet4")
        .Range("A4").Value = Cato0 & " TO " & Cato1
        .Range("A5").Value = Cato1 & " TO " & Cato2
        .Range("A6").Value = Cato2 & " TO " & Cato3
        .Range("A7").Value = Cato3 & " TO " & Cato4
        .Range("A8").Value = Cato4 & " TO " & Cato5
        .Range("A9").Value = Cato5 & " TO " & Cato6
        .Range("A10").Value = Cato6 & " TO " & Cato7
        .Range("A11").Value = Cato7 & " TO " & Cato8
        .Range("A12").Value = ">" & Cato8
        .Range("B13").Value = PolNo - 1

        .Range("C4:C12").NumberFormat = "0.00%"
        '.Range("D4:D12").NumberFormat = "000.000.000.000,00"
        .Range("H4:H12").NumberFormat = "0.00%"
        '.Range("E4:E12").NumberFormat = "000.000.000.000,00"
        For i = 4 To (NOCatoI + 3)
            .Range("B" & i).Value = PremiumCount(i - 3)
            .Range("D" & i).Value = TotalPremium(i - 3)
            .Range("E" & i).Value = TotalCommission(i - 3)
            .Range("H" & i).Value = TotalCommission(i - 3) / TotalPremium(i - 3) ''Error when TotalCommission = 0 and TotalPremium = 0
            .Range("C" & i).Value = PremiumCount(i - 3) / PolNo
        Next i
    End With
end sub

Answer 1

一个简单的方法可能是取值范围的最大值并均匀分布比例。

因此，假设您的数据集900; 10000; 5000; 4000; 3000; 17000; 8000; 7000并且您希望缩放8值

这可以通过将最大值17000除以您期望8刻度值的计数并将其乘以刻度位置来完成：

• 刻度值 0：17000 / 8 * 0
• 比例值 1：17000 / 8 * 1
• 比例值 2：17000 / 8 * 2
• 。
• 比例值 8：17000 / 8 * 8

所以我们最终会得到一个这样的量表：0; 2125; 4250; 6375; 8500; 10625; 12750; 14875; 17000

下面是一个示例：

Option Explicit
Public Sub test()
    Dim MyScale As Variant
    MyScale = GetScaleFromValues(TargetRange, 8) 'get 8 scale values from value range
    Dim i As Long
    For i = LBound(MyScale) To UBound(MyScale)
        Debug.Print CStr(MyScale(i)) 'print out all scale values
    Next i
    'or access each scale value individually by
    Debug.Print MyScale(5) 'for the fifth scale value
End Sub
Public Function GetScaleFromValues(ValueRange As Range, Optional ScaleCount As Long = 8) As Variant
    Dim MyScale() As Double
    ReDim MyScale(ScaleCount) As Double
    Dim MaxValue As Double
    MaxValue = Application.WorksheetFunction.Max(ValueRange)
    Dim i As Long
    For i = LBound(MyScale) To UBound(MyScale)
        MyScale(i) = (MaxValue / ScaleCount) * i
    Next i
    GetScaleFromValues = MyScale
End Function

Answer 2

如果我

没记错的话，您想提供动态缩放到 Cat1 到 Cat8。在这种情况下，您可以使用"输入框函数"为Cat1到Cat8的已定义变量提供值。