计算总和

Question

我想要做的是开发一个模型，该模型采用大于1的单元格，然后使用圆锥形状将区域的总和取为第一行，例如单元格D4，求和区域C3： C5 + B2：B6 + A1：A7。

目前我有这个，但显然不起作用。

    Dim I As Double
    Dim J As Double
    Dim Size As Integer
    Dim x As Integer
    Dim y As Integer
    Dim z As Integer
    'Dim Range As Integer
    Dim PV1 As Integer





    'MCArray = Worksheets("Data")
    I = WorksheetFunction.CountA(Worksheets("Data").Rows(1))
    J = WorksheetFunction.CountA(Worksheets("Data").Columns(1))


    'Loop to Move down the rows
    For x = 1 To J
        'Loop to move acoss the columns
        For y = 1 To I
            'IfElse to determine if cell value is greater or equal to zero
            If Cells(J, I).Value >= 0 Then
                'Loop to sum the cells above
                For z = 1 To J
                    PV1 = (ActiveCell.Value) + Worksheet.Sum(Range([J - z], [I-z:I+z]))
                    'IfElse to determine if final sum is greater than zero
                    If PV1 > 0 Then
                        Worksheets("MC").Range("B4").Value = PV1
                        Range([J - z], [I-z:I+z]).Interior.ColourIndex = 1

                    End If
                Next z
            End If
        Next y
    Next x

Answer 1

这是一个可以用作UDF或其他例程的函数。只需将您想要开始的单个单元格传递给您（在您的示例中为D4），此函数将计算您所描述的圆锥体的总和。

Public Function SUMCONE(r As Range) As Double
    Application.Volatile
    SUMCONE = Application.Sum(r, r(-0, -0).Resize(, 3), r(-1, -1).Resize(, 5), r(-2, -2).Resize(, 7))
End Function

以下是如何在VBA例程中使用上述功能的示例：

Public Sub Demo()
    Dim j&
    For j = 5 To 10
        If Cells(5, j) > 0 Then
            Debug.Print SUMCONE(Cells(5, j))
        End If
    Next
End Sub

<强>更新

根据您的反馈，我更新了函数和演示例程，以便从初始单元格形成向上的锥形求和。

更新＃2

以上是针对固定大小的锥体，向上延伸，可以从工作表中的任何单元格启动。

但是如果您希望锥体始终一直延伸到第1行而不管它来自哪个单元格，那么以下就是您所追求的：

Public Sub Demo()
    Dim i&, j&
    For j = 1 To Application.CountA(Worksheets("Data").Rows(1))
        For i = 1 To Application.CountA(Worksheets("Data").Columns(1))
            If Cells(i, j) > 0 Then
                Debug.Print Cells(i, j).Address, SumAndColorCone(Cells(i, j))
            End If
        Next
    Next
End Sub

Public Function SumAndColorCone(r As Range) As Double
    Dim i&, k&, c As Range
    Set c = r
    For i = r.Row - 1 To 1 Step -1
        Set c = Union(c, r(-k, -k).Resize(, (k + 1) * 2 + 1))
        k = k + 1
    Next
    c.Interior.Color = vbRed
    SumAndColorCone = Application.Sum(c)
End Function

更新＃3

我怀疑如果锥体太靠近工作表的左边缘，则会出现问题。我已经添加了代码来处理它。您访问大型矩阵（我在Demo例程中使用过）的方法也无法正常工作。我也解决了这个问题：

Public Sub Demo()
    Dim i&, j&
    For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
        For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
            If Val(Cells(i, j)) > 0 Then
                Debug.Print Cells(i, j).Address, SumAndColorCone(Cells(i, j))
            End If
        Next
    Next
End Sub

Public Function SumAndColorCone(r As Range) As Double
    Dim i&, k&, c As Range
    Set c = r
    For i = r.Row - 1 To 1 Step -1
        If r.Column - k < 2 Then Exit For
        Set c = Union(c, r(-k, -k).Resize(, (k + 1) * 2 + 1))
        k = k + 1
    Next
    c.Interior.Color = vbRed
    SumAndColorCone = Application.Sum(c)
End Function