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

我在挣扎。我有一个工作完美的代码，但我必须在代码中设置我自己的范围（比例），如您所见（cato0到cato8）。我的代码必须对所有类型的数据（货币）起作用，可能是数百万，也可能是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

子测试（）
调暗Cato0为双色，Cato1为双色，Cato2为双色，Cato3为双色，Cato4为双色_
Cato5为双精度，Cato6为双精度，Cato7为双精度，Cato8为双精度，Cato9为字符串
Cato0=0
Cato1=500
Cato2=1000
Cato3=2500
Cato4=5000
Cato5=7500
Cato6=10000
Cato7=12500
Cato8=15000
变暗目标范围作为范围
Dim TotalPremium（）为双精度
Dim PremiumCount（）的长度与
将总佣金（）设置为双精度
Dim cell premium（）为双精度
暗淡的波尔诺
暗淡单元格作为范围
作为整数的Dim NOCatoI
NOCatoI=9'个目录编号
波尔诺=1
雷迪姆PremiumCount（1至NOCatoI）
ReDim TotalPremium（1至NOCatoI）
ReDim TotalCommission（1至NOCatoI）
使用此工作簿。工作表（“表3”）
lastRow=.Cells（Rows.Count，2）.End（xlUp）.Row
LastColumn=.Cells（1，Columns.Count）.End（xlToLeft）.Column
'设置目标范围=范围（“CC2:CC”和lastRow）
以
Set-TargetRange=ThisWorkbook.Sheets（“Sheet3”）.Range（“CC2:CC”和lastRow）
对于TargetRange中的每个单元格
带电池
如果.Value Cato1）和（.Value Cato2）和（.Value Cato3）和（.Value Cato4）和（.Value Cato5）和（.Value Cato6）和（.Value Cato7）和（.Value如果我没有错，您希望提供Cat1到Cat8的动态缩放。在这种情况下，您可以使用“InputBox函数为Cat1到Cat8的已定义变量提供值。
一种简单的方法是取最大值范围并均匀分布刻度

因此，假设您的数据集是
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

对我来说，你的要求是非常不清楚的。你说的“必须四舍五入到完美的明显刻度”是什么意思。你能举一些例子吗？@PeH，就像下面的答案（由Parveen Soroha给出）我的目标是“动态地刻度到Cat1到Cat8”。因此，如果您的问题是如何让用户能够输入这些刻度，那么您的答案如下：
InputBox
或者是一个要求输入所有这些刻度的用户表单。@Peh，是的，但是是否可以用自动方式而不是手动方式。手动方式每次都会花费太多时间。您的意思是什么“自动”，应该猜到还是什么？如果你想让VBA为你选择刻度，这必须遵循一条规则。因此，你需要知道应该应用哪条规则来找到正确的刻度。Sroha，感谢你的输入，我知道我可以实现“为Cat1到Cat8提供动态刻度”的目标（顺便说一句，谢谢你对我的问题做了更好的解释）。但是我99%确信它可以自动完成，而不是用输入框，但我自己也不知道怎么做。我是你们中的一个dooes@pEh谢谢！太棒了！