[已解决]请教：计算百分比、百分数之和是36.8%的位置

lygyjt

请教老师：
1、B列是已知变量（行数及数值大小都是变量），当它变化时，C列自动计算：C2=（B2除以B列全部数据之和）%；C3=（B3除以B列全部数据之和）%。C列其它数据以此类推，精确到小数点后13位，虽然单元格显示的是小数点后2位。
2、C列计算完成后，此列每个单元格都对它下面（包括它自己）所有单元格进行求和计算，当哪个单元格的求和值等于或最接近36.8%，把这个单元格涂红。
比如：sum(c10:c34)=34.472%，sum(c9:c34)=39.1304%。36.8-34.472=2.328，36.8-39.13=2.3304。显然C10单元格的求和更接近于36.8%，所以，在C10处涂红。

具体例子： 计算百分比、百分数之和是36.8%的位置.rar (8.16 KB, 下载次数: 8)

2022-6-27 17:56 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

我行我速2008

2022-6-27 19:33

Sub tt()
    Dim Ar, R%, X%, He%, Num As Single
    With ActiveSheet
        .Range("A1").CurrentRegion.Interior.ColorIndex = 0
        Ar = .Range("A1").CurrentRegion
        R = UBound(Ar)
        For X = 2 To R
            He = He + Ar(X, 2)
        Next X
        For X = 2 To R
            Ar(X, 3) = Round(Ar(X, 2) / He, 15)
        Next X
        .Range("A1").Resize(R, UBound(Ar, 2)) = Ar
        For X = R To 2 Step -1
            Num = Num + Ar(X, 3)
            If Num = 0.368 Then
                .Cells(X, 3).Interior.ColorIndex = 3
            ElseIf Num > 0.368 Then
                If Num - 0.368 - (0.368 - Application.Sum(.Range(.Cells(X + 1, 3), .Cells(R, 3)))) < 0 Then
                    .Cells(X, 3).Interior.ColorIndex = 3
                Else
                    .Cells(X + 1, 3).Interior.ColorIndex = 3
                End If
                GoTo 100
            End If
        Next X
100:
    End With
End Sub

跳转到最佳答案楼层

我行我速2008

Sub tt()
    Dim Ar, R%, X%, He%, Num As Single
    With ActiveSheet
        .Range("A1").CurrentRegion.Interior.ColorIndex = 0
        Ar = .Range("A1").CurrentRegion
        R = UBound(Ar)
        For X = 2 To R
            He = He + Ar(X, 2)
        Next X
        For X = 2 To R
            Ar(X, 3) = Round(Ar(X, 2) / He, 15)
        Next X
        .Range("A1").Resize(R, UBound(Ar, 2)) = Ar
        For X = R To 2 Step -1
            Num = Num + Ar(X, 3)
            If Num = 0.368 Then
                .Cells(X, 3).Interior.ColorIndex = 3
            ElseIf Num > 0.368 Then
                If Num - 0.368 - (0.368 - Application.Sum(.Range(.Cells(X + 1, 3), .Cells(R, 3)))) < 0 Then
                    .Cells(X, 3).Interior.ColorIndex = 3
                Else
                    .Cells(X + 1, 3).Interior.ColorIndex = 3
                End If
                GoTo 100
            End If
        Next X
100:
    End With
End Sub

sam-wang

請測試看看，謝謝

Sub test()
Dim Arr, s, T, T1, i&
Arr = Range([d1], [a65536].End(3))
For i = 2 To UBound(Arr): s = s + Arr(i, 2): Next
For i = 2 To UBound(Arr): Arr(i, 3) = Arr(i, 2) / s: Next
Range("a1").Resize(UBound(Arr), 3) = Arr
For i = 2 To UBound(Arr)
    T = 0
    For i1 = i To UBound(Arr): T = T + Arr(i1, 3): Next
    T = Abs(0.368 - T)
    If T1 = "" Then
        T1 = T
    ElseIf T < T1 Then
        T1 = T: s = i
    End If
Next
Range("c2:c" & i).Interior.ColorIndex = 0
Cells(s, 3).Interior.Color = 255
End Sub

lygyjt

我行我速2008 发表于 2022-6-27 19:33
Sub tt()
    Dim Ar, R%, X%, He%, Num As Single
    With ActiveSheet

谢谢老师的帮助！

lygyjt

sam-wang 发表于 2022-6-27 21:43
請測試看看，謝謝

Sub test()

近期让老师为我操了不少心啊！您受累了！