使用VBA在Excel中创build季度，半年和年度汇总公式的好方法？

我在文档中有一个与图像布局相同的日历栏。 日历是从Power Pivot中复制的，但是我想用公式计算四分之一，半年和一年的单元格。 我想用VBA创build这些公式。 有没有什么聪明的方法来做到这一点？

日历可以在任何月份和年份开始和结束。 季度，半年和年度并不总是完整的，这意味着整个3个月，6个月或12个月并不总是包含在日历中。

我最好的想法是三次遍历所有列。 第一次，逐月build立一个SUM公式，直到登陆一年，然后把公式写到那一栏。 下一次，半年的专栏也一样。 第三次，为四分之一列做同样的事情。 但是这似乎太复杂了，不能做这么简单的事情。

Answer 1

您只需要运行一次循环，如下面的代码所示。 我已经猜测了你没有包含在代码中的函数和variables，所以这里是整个模块：

Option Explicit Private Enum CellType Unknown Month Quarter Half Year End Enum Private Const YEAR_ROW As Long = 1 Private Const HALF_ROW As Long = 2 Private Const QUARTER_ROW As Long = 3 Private Const MONTH_ROW As Long = 4 Private Const FIRST_VALUE_ROW As Long = 5 Private mWS As Worksheet Private mRowCount As Long Sub RunMe() Dim ws As Worksheet Dim lastCol As Long Dim c As Long Dim quarterRange As Range Dim halfRange As Range Dim yearRange As Range Set mWS = ThisWorkbook.Worksheets("Sheet1") '~~> amend as necessary mRowCount = mWS.Cells.Find(What:="*", _ After:=mWS.Cells(1), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row - FIRST_VALUE_ROW lastCol = mWS.Cells(YEAR_ROW, mWS.Columns.Count).End(xlToLeft).Column For c = 1 To lastCol Select Case GetCellType(c) Case CellType.Month Set quarterRange = Unionised(quarterRange, c) Case CellType.Quarter Set halfRange = Unionised(halfRange, c) Set quarterRange = FilledAndCleared(quarterRange, c) Case CellType.Half Set yearRange = Unionised(yearRange, c) Set halfRange = FilledAndCleared(halfRange, c) Case CellType.Year Set yearRange = FilledAndCleared(yearRange, c) End Select Next End Sub Private Function GetCellType(c As Long) As CellType Dim content As String If Len(CStr(mWS.Cells(MONTH_ROW, c).Value2)) > 0 Then GetCellType = CellType.Month: Exit Function If InStr(CStr(mWS.Cells(QUARTER_ROW, c).Value2), "Total") > 0 Then GetCellType = CellType.Quarter: Exit Function If InStr(CStr(mWS.Cells(HALF_ROW, c).Value2), "Total") > 0 Then GetCellType = CellType.Half: Exit Function If InStr(CStr(mWS.Cells(YEAR_ROW, c).Value2), "Total") > 0 Then GetCellType = CellType.Year: Exit Function GetCellType = CellType.Unknown End Function Private Function Unionised(oldRng As Range, c As Long) As Range If oldRng Is Nothing Then Set Unionised = mWS.Cells(FIRST_VALUE_ROW, c) Else Set Unionised = Union(oldRng, mWS.Cells(FIRST_VALUE_ROW, c)) End If End Function Private Function FilledAndCleared(rng As Range, c As Long) As Range Dim i As Long For i = 0 To mRowCount rng.Worksheet.Cells(FIRST_VALUE_ROW + i, c).Formula = "=SUM(" & rng.Offset(i).Address(False, False) & ")" Next Set FilledAndCleared = Nothing End Function 

Answer 2

这就是我解决它的方法。 我会欢迎一个更简单的解决scheme。

 'Year sFormula = "" For c = 6 To LastColumn(wksTarget) If wksTarget.Cells(lMonthsRow, c) <> "" Then sFormula = sFormula & "+" & wksTarget.Cells(lFirstItemRow, c).Address(RowAbsolute:=False, ColumnAbsolute:=False) End If If wksTarget.Cells(lMonthsRow, c) = "" And InStr(1, wksTarget.Cells(lYearsRow, c), "Total") Then wksTarget.Range(wksTarget.Cells(lFirstItemRow, c), wksTarget.Cells(LastRow(wksTarget), c)) = "=" & sFormula Call FormatAsTotal(wksTarget.Range(wksTarget.Cells(lFirstItemRow, c), wksTarget.Cells(LastRow(wksTarget), c))) sFormula = "" End If Next 'Half year sFormula = "" For c = 6 To LastColumn(wksTarget) If wksTarget.Cells(lMonthsRow, c) <> "" Then sFormula = sFormula & "+" & wksTarget.Cells(lFirstItemRow, c).Address(RowAbsolute:=False, ColumnAbsolute:=False) End If If wksTarget.Cells(lMonthsRow, c) = "" And InStr(1, wksTarget.Cells(lHalfYearsRow, c), "Total") Then wksTarget.Range(wksTarget.Cells(lFirstItemRow, c), wksTarget.Cells(LastRow(wksTarget), c)) = "=" & sFormula Call FormatAsSubtotal(wksTarget.Range(wksTarget.Cells(lFirstItemRow, c), wksTarget.Cells(LastRow(wksTarget), c))) sFormula = "" End If Next 'Quarter sFormula = "" For c = 6 To LastColumn(wksTarget) If wksTarget.Cells(lMonthsRow, c) <> "" Then sFormula = sFormula & "+" & wksTarget.Cells(lFirstItemRow, c).Address(RowAbsolute:=False, ColumnAbsolute:=False) End If If wksTarget.Cells(lMonthsRow, c) = "" And InStr(1, wksTarget.Cells(lQuartersRow, c), "Total") Then wksTarget.Range(wksTarget.Cells(lFirstItemRow, c), wksTarget.Cells(LastRow(wksTarget), c)) = "=" & sFormula Call FormatAsSubtotal(wksTarget.Range(wksTarget.Cells(lFirstItemRow, c), wksTarget.Cells(LastRow(wksTarget), c))) sFormula = "" End If Next 

Answer 3

如果根据下面的图片设置月份和总和（我从你的图片中获得），我的答案将起作用。

 Sub SomeSub() Dim r As Long Dim LastRow As Long With ActiveSheet.UsedRange 'Getting the last Row of the used range LastRow = .Rows(.Rows.Count).Row - 1 End With 'Loop for the rows of data For r = 5 To LastRow 'Quarter Calculation 'Quarter 1 Range("D" & r).Value = Application.WorksheetFunction.Sum(Range("A" & r), Range("B" & r), Range("C" & r)) 'Quarter 2 Range("H" & r).Value = Application.WorksheetFunction.Sum(Range("E" & r), Range("F" & r), Range("G" & r)) 'Quarter 3 Range("Q" & r).Value = Application.WorksheetFunction.Sum(Range("J" & r), Range("K" & r), Range("K" & r)) 'Quarter 4 Range("M" & r).Value = Application.WorksheetFunction.Sum(Range("N" & r), Range("O" & r), Range("P" & r)) 'Bi Annual Calculation 'First 6 Months Range("I" & r).Value = Application.WorksheetFunction.Sum(Range("A" & r), Range("B" & r), Range("C" & r), _ Range("E" & r), Range("F" & r), Range("G" & r)) 'Second 6 Months Range("R" & r).Value = Application.WorksheetFunction.Sum(Range("J" & r), Range("K" & r), Range("K" & r), _ Range("N" & r), Range("O" & r), Range("P" & r)) 'Year Calculation Range("S" & r).Value = Application.WorksheetFunction.Sum(Range("A" & r), Range("B" & r), Range("C" & r), _ Range("E" & r), Range("F" & r), Range("G" & r), _ Range("J" & r), Range("K" & r), Range("K" & r), _ Range("N" & r), Range("O" & r), Range("P" & r)) Next End Sub 

编辑

考虑到OP对Quarters可能并不总是有3个月的评论，首先需要确定四分之一范围。

请参阅下面的新脚本：

 Sub SomeOtherSub() Dim YrStart As Long, YrEnd As Long Dim H1Start As Long, H1End As Long Dim H2Start As Long, H2End As Long Dim Q1Start As Long, Q1End As Long, Q1T As Long Dim Q2Start As Long, Q2End As Long, Q2T As Long Dim Q3Start As Long, Q3End As Long, Q3T As Long Dim Q4Start As Long, Q4End As Long, Q4T As Long Dim LastRow As Long Dim col As Long With ActiveSheet.UsedRange 'Getting the last Colunm of the used range LastColumn = .Columns(.Columns.Count).Column End With 'InStr() = 0 means that the text is not included in the string 'InStr() > 0 means that the text is included in the string 'Getting the Ranges for each Quarter For col = 1 To LastColumn aa = Cells(3, col) If InStr(aa, "Q1") > 0 And InStr(aa, "Total") = 0 Then Q1Start = col If InStr(aa, "Q1") > 0 And InStr(aa, "Total") > 0 Then Q1End = col - 1 ' -1 for the end of the data for the quarter Q1T = col End If If InStr(aa, "Q2") > 0 And InStr(aa, "Total") = 0 Then Q2Start = col If InStr(aa, "Q2") > 0 And InStr(aa, "Total") > 0 Then Q2End = col ' -1 for the end of the data for the quarter Q2T = col End If If InStr(aa, "Q3") > 0 And InStr(aa, "Total") = 0 Then Q3Start = col If InStr(aa, "Q3") > 0 And InStr(aa, "Total") > 0 Then Q3End = col - 1 ' -1 for the end of the data for the quarter Q3T = col End If If InStr(aa, "Q4") > 0 And InStr(aa, "Total") = 0 Then Q4Start = col If InStr(aa, "Q4") > 0 And InStr(aa, "Total") > 0 Then Q4End = col - 1 ' -1 for the end of the data for the quarter Q4T = col End If Next 'Getting the Ranges for each Bi Annual For col = 1 To LastColumn aa = Cells(2, col) If InStr(aa, "H1") > 0 And InStr(aa, "Total") = 0 Then H1Start = col If InStr(aa, "H1") > 0 And InStr(aa, "Total") > 0 Then H1T = col If InStr(aa, "H2") > 0 And InStr(aa, "Total") = 0 Then H2Start = col If InStr(aa, "H2") > 0 And InStr(aa, "Total") > 0 Then H2T = col Next 'Getting the Ranges for the year For col = 1 To LastColumn aa = Cells(1, col) If Len(aa) > 0 And InStr(aa, "Total") = 0 Then YrStart = col If Len(aa) > 0 And InStr(aa, "Total") > 0 Then YrT = col Next With ActiveSheet.UsedRange 'Getting the last Row of the used range LastRow = .Rows(.Rows.Count).Row - 1 End With 'Loop for the rows of data For r = 5 To LastRow 'Quarter Calculation 'Quarter 1 Cells(r, Q1T).Value = Application.WorksheetFunction.Sum(Range(Cells(r, Q1Start), Cells(r, Q1End))) 'Quarter 2 Cells(r, Q2T).Value = Application.WorksheetFunction.Sum(Range(Cells(r, Q2Start), Cells(r, Q2End))) 'Quarter 3 Cells(r, Q3T).Value = Application.WorksheetFunction.Sum(Range(Cells(r, Q3Start), Cells(r, Q3End))) 'Quarter 4 Cells(r, Q4T).Value = Application.WorksheetFunction.Sum(Range(Cells(r, Q4Start), Cells(r, Q4End))) 'Bi Annual Calculation 'First 6 Months Cells(r, H1T).Value = Application.WorksheetFunction.Sum(Cells(r, Q1T), Cells(r, Q2T)) 'Second 6 Months Cells(r, H2T).Value = Application.WorksheetFunction.Sum(Cells(r, Q3T), Cells(r, Q4T)) 'Year Calculation Cells(r, YrT).Value = Application.WorksheetFunction.Sum(Cells(r, H1T), Cells(r, H2T)) Next End Sub