计算总和

我想要做的是开发一个模型，采取一个大于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], [Iz: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], [Iz: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 

UPDATE

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

更新＃2

以上是针对向上延伸的固定尺寸锥体，可以从工作表中的任何单元开始。

但是如果你更喜欢锥体始终一直延伸到第1行，而不pipe它起源于哪个单元格，那么以下就是你所追求的内容：

 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

正如我怀疑，如果锥开始太靠近工作表的左边缘有问题。 我已经添加了代码来处理现在。 此外，您访问大型matrix（我已经在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