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

Question

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

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

我最好的想法是将所有列循环三次。第一次，逐月构建SUM公式，直到登陆年份列，然后将公式写入该列。下一次，做同样的半年专栏。第三次，对季度列做同样的事情。但这似乎太复杂了，不能做这么简单的事情。

Answer 1

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

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

这就是我解决它的方式。我欢迎一个更简单的解决方案。

'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 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

修改

考虑到OP的意见，即宿舍可能并不总是有3个月，首先需要确定季度范围。

请参阅下面的新脚本：

regex