VBAで、複数行あるカテゴリーごとの合計値の算出ができない

Question

実現したいこと

大項目ごとの合計数字を代入したい。該当する列に。
添付の画像の①30行目と②40行目のカテゴリー別の合計行に、①には、23行目と29行目の小項目の合計を、②には、33行目と39行目の小項目の合計を該当する列に代入したい。
小項目の合計だけをうまく取得して、カテゴリー別の合計行に代入できないかと考えています。

発生している問題・分からないこと

＜困っていること＞
合計する行は固定の行ではないので、「合計」という文字列のある行を取得して、合計するようにしていますが、
①だけならうまくいくのですが、
②の合計を算出する際に、①の下の行からカウントしなければならないのですが（1行目からだと二重計上になるため）、それがうまくいきません。
なぜか、②の行には0が代入されてしまいます。

該当のソースコード

※試しに以下のコードで一つの列で合計値を出したのですが、問題なく算出され代入されます。

Sub CalculateSpecificSum()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim sumRow As Long
    Dim totalSum As Double
    Dim currentRow As Long
    
    ' シートを指定
    Set ws = ThisWorkbook.Sheets("収益状況")
    
    ' 合計値を初期化
    totalSum = 0
    
    ' A列の最初の「合計」行を取得
    sumRow = ws.Columns("A").Find(What:="合計", LookAt:=xlPart, MatchCase:=False).Row

    ' A列の「合計」行までループ
    For currentRow = 6 To sumRow - 1 ' 合計行の直前まで
        ' B列が「合計」の場合のみ処理
        If ws.Cells(currentRow, "B").value Like "*合計*" Then
            ' 12列目（L列）の値を加算
            totalSum = totalSum + ws.Cells(currentRow, 12).value
        End If
    Next currentRow

    ' 合計値をA列の「合計」行のL列に代入
    ws.Cells(sumRow, 12).value = totalSum
    
    MsgBox "指定された合計の計算が完了しました！", vbInformation
End Sub


※以下は、各列ごとに合計値を算出するようにしているはずなのですが、0となり算出されません。

Sub ProcessRevenueSums()
    Dim ws As Worksheet
    Dim sumRow As Long
    Dim totalSum As Double
    Dim currentRow As Long
    Dim colIndex As Variant
    Dim sumColumns As Variant
    
    ' シートを指定
    Set ws = ThisWorkbook.Sheets("収益状況")
    
    ' 合計する列を指定
    sumColumns = Array(12, 13, 14, 18, 19, 20, 21, 24, 25, 26, 27, 28, 29, 30, _
                       34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48)

    ' A列の最初の「合計」行を取得
    sumRow = ws.Columns("A").Find(What:="合計", LookAt:=xlPart, MatchCase:=False).Row

    ' 各列を順次処理
    For Each colIndex In sumColumns
        ' 合計値を初期化
        totalSum = 0
        
        ' A列の「合計」行までの範囲をループ
        For currentRow = 6 To sumRow - 1 ' 合計行の直前まで
            ' B列が「合計」の場合のみ処理
            If ws.Cells(currentRow, "B").value Like "*合計*" Then
                ' 該当列の値を加算
                totalSum = totalSum + ws.Cells(currentRow, colIndex).value
            End If
        Next currentRow

        ' 合計値をA列の「合計」行に代入
        ws.Cells(sumRow, colIndex).value = totalSum
    Next colIndex
    
    MsgBox "指定された列に順次合計を代入しました！", vbInformation
End Sub

試したこと・調べたこと

• teratailやGoogle等で検索した
• ソースコードを自分なりに変更した
• 知人に聞いた
• その他

上記の詳細・結果

上記に記載のとおりですが、どうしてもうまくいきません。
Excelの関数でしたら実現できると思うのですが、該当する行が変わるので、その都度入力する手間もかかるため、VBAで実現できないかと考えています。
どなたか力を貸していただければ幸いです。
よろしくお願いいたします。

補足

特になし

Comments

[yambejp]

もう少し簡素な例で説明できませんか？何をどうしたいかかなり分かりづらいです

[Shin_go]

ご指摘いただきましてありがとうございました。わかりずらく申し訳ございません。
他の方の回答で対応することができました。
またご意見などいただけますと幸いです。

[meg_]

> 他の方の回答で対応することができました。
解決されたとのことで良かったです。
ベストアンサーを選んで質問をクローズしてください。

Answer 1

Excelの関数でしたら実現できると思うのですが

Sub SetFormulaCells()
    
    Const targetSuffix = "合計"
    
    Dim ws As Worksheet
    
    Set ws = ThisWorkbook.Sheets("収益状況")
    
    Dim firstRow As Long
    Dim lastRow As Long
      
    With ws
        firstRow = 6
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        
        If firstRow > lastRow Then
            Set ws = Nothing
            Exit Sub
        End If
        
    End With
    
    Dim targetColumns As Variant
    
    targetColumns = Array(Array(12, 14), _
                          Array(18, 21), _
                          Array(24, 30), _
                          Array(34, 48))
      
    Dim currentRow As Long
    Dim rowHeader1 As Excel.Range
    Dim rowHeader2 As Excel.Range
    Dim groupName1 As String
    Dim groupName2 As String
    Dim targetColumn As Variant
    Dim sumRange As String
    Dim criteriaRange1 As String
    Dim criteria1 As String
    Dim criteriaRange2 As String
    Dim criteria2 As String
    Dim formulaRange As Excel.Range
    Dim formulaString As String
    
    Application.Calculation = xlCalculationManual
    
    For currentRow = firstRow To lastRow
        
        groupName1 = ""
        groupName2 = ""
        
        Set rowHeader1 = ws.Cells(currentRow, "A")
        Set rowHeader2 = ws.Cells(currentRow, "B")
        
        If rowHeader1.Value Like ("*" & targetSuffix) Then
            
            groupName1 = Left(rowHeader1.Value, Len(rowHeader1.Value) - Len(targetSuffix))
            groupName2 = "*" & targetSuffix
        
            criteria1 = "LEFT(" & rowHeader1.Address(False, True) & "," & _
                              "LEN(" & rowHeader1.Address(False, True) & ")" & _
                              "-" & Len(targetSuffix) & ")"
            criteria2 = """*" & targetSuffix & """"
            
        ElseIf rowHeader2.Value Like ("*" & targetSuffix) Then
            groupName1 = rowHeader1.Value
            groupName2 = Left(rowHeader2.Value, Len(rowHeader2.Value) - Len(targetSuffix))
        
            criteria1 = rowHeader1.Address(False, True)
            criteria2 = "LEFT(" & rowHeader2.Address(False, True) & "," & _
                              "LEN(" & rowHeader2.Address(False, True) & ")" & _
                              "-" & Len(targetSuffix) & ")"
        End If
        
        If groupName1 <> "" And groupName2 <> "" Then
            
            Debug.Print "グループ1: " & groupName1
            Debug.Print "グループ2: " & groupName2
            
            criteriaRange1 = rowHeader1.EntireColumn.Address(True, True)
            criteriaRange2 = rowHeader2.EntireColumn.Address(True, True)
            
            For Each targetColumn In targetColumns
                
                Set formulaRange = ws.Range(ws.Cells(currentRow, targetColumn(0)), _
                                            ws.Cells(currentRow, targetColumn(1)))
                
                sumRange = ws.Columns(targetColumn(0)).Address(False, False)
                
                formulaString = "=SUMIFS(" & sumRange & "," & _
                                             criteriaRange1 & "," & _
                                             criteria1 & "," & _
                                             criteriaRange2 & "," & _
                                             criteria2 & ")"
                
                Debug.Print vbTab & "数式セル範囲: " & formulaRange.Address(False, False)
                Debug.Print vbTab & "設定する数式: " & formulaString
                
                formulaRange.Formula = formulaString
                
                Set formulaRange = Nothing
            Next
        
        End If
        
        Set rowHeader1 = Nothing
        Set rowHeader2 = Nothing
    
    Next
    
    Application.Calculation = xlCalculationAutomatic
    
    Set ws = Nothing
    
End Sub

Comments

[Shin_go]

回答ありがとうございます。
ベストアンサーは別の方を選ばせていただきましたが、こちらの回答も非常に参考になりました。

Answer 2

A列の合計セルをFindで探していますが、Findは最初に一致したセルしか探しません。次のセルを探すには、FindNextを使います。この２つのメソッドを使ってループさせるのことになります。(下記参照)

【VBA入門】Find、FindNextで検索(完全一致、部分一致、複数一致)

ただし、このメソッドは遅いし、複雑なコードになります。
B列はFor ... Next でループして1セルずつチェックしているので、A列も同様にチェックすれば一つのループですみシンプルなコードになります。
つまり、下記のような考え方になります。
ループ処理で先頭行から順に行移動
B列に「合計」が含まれるなら集計列の値を変数に加算、
A列が「合計」なら集計列のセルに出力、変数は0にリセット

ということで、まず、CalculateSpecificSum は下記のようなコードになります。

Sub CalculateSpecificSum()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim totalSum As Currency
    Dim currentRow As Long
    
    ' シートを指定
    Set ws = ThisWorkbook.Sheets("収益状況")
    
    ' 合計値を初期化
    totalSum = 0
    
    ' A列の最終行を取得
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' A列の最終行までループ
    For currentRow = 6 To lastRow
        ' B列が「合計」の場合
        If ws.Cells(currentRow, "B").Value Like "*合計*" Then
            ' 12列目（L列）の値を加算
            totalSum = totalSum + ws.Cells(currentRow, 12).Value
        ' A列が「合計」の場合
        ElseIf ws.Cells(currentRow, "A").Value Like "*合計*" Then
            ' 合計値をA列の「合計」行のL列に代入
            ws.Cells(currentRow, 12).Value = totalSum
            totalSum = 0
        End If
    Next currentRow
    
    MsgBox "指定された合計の計算が完了しました！", vbInformation
End Sub

※ちなみに、totalSum は浮動小数点数型(Double)で宣言していますが、 浮動小数点数は演算誤差が出るので、集計するなら整数ならLong型、小数も含むならCurrency型で宣言するべきです。

---

ProcessRevenueSums は複数列の集計を格納する必要があるので、配列変数に集計値を格納するようにします。
あとは上のコードと同様の考え方でワンループで順次処理します。

Sub ProcessRevenueSums()
    Dim ws As Worksheet
    Dim LastRow As Long
    Dim totalSums() As Long
    Dim currentRow As Long
    Dim aryIndex As Long
    Dim sumColumns As Variant
    
    ' シートを指定
    Set ws = ThisWorkbook.Sheets("収益状況")
    
    ' 合計する列を指定
    sumColumns = Array(12, 13, 14, 18, 19, 20, 21, 24, 25, 26, 27, 28, 29, 30, _
                       34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48)
    ' 各列の合計値を格納する配列を初期化
    ReDim totalSums(UBound(sumColumns))

    ' A列の最終行を取得
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' A列の最終行までループ
    For currentRow = 6 To LastRow
        ' B列が「合計」の場合
        If ws.Cells(currentRow, "B").Value Like "*合計*" Then
            ' 各列の集計に加算
            For aryIndex = 0 To UBound(sumColumns)
                totalSums(aryIndex) = totalSums(aryIndex) + ws.Cells(currentRow, sumColumns(aryIndex)).Value
            Next aryIndex
        ElseIf ws.Cells(currentRow, "A").Value Like "*合計*" Then
            ' 各列を集計をセルに出力
            For aryIndex = 0 To UBound(sumColumns)
                ws.Cells(currentRow, sumColumns(aryIndex)).Value = totalSums(aryIndex)
                totalSums(aryIndex) = 0
            Next aryIndex
        End If
    Next currentRow
    
    MsgBox "指定された列に順次合計を代入しました！", vbInformation
End Sub

---

Excelの関数でしたら実現できると思うのですが、該当する行が変わるので、その都度入力する手間もかかるため、VBAで実現できないかと考えています。

VBAで集計関数(SUMIF)を使った数式を生成してセルに代入するサンプルコードも置いておきます。

Public Sub SetSumFormula()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("収益状況")
    
    Dim LastRow As Long ' A列の最終行
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    Dim SumCells As Range ' 集計セル
    Set SumCells = ws.Range("L1:N1,R1:U1,X1:AD1,AH1:AV1")
    
    Const conFormula = "=SUMIF($B#1:$B#2,""*合計*"",L#1:L#2)" '集計数式テンプレート, #1=集計開始行,#2=集計最終行
    
    Application.Calculation = xlCalculationManual
    
    Dim beginRow As Long '集計開始行
    beginRow = 6
    Dim currentRow As Long
    For currentRow = 6 To LastRow
        If ws.Cells(currentRow, "A").Value Like "*合計*" Then
            With SumCells.Offset(currentRow - 1)
                .Value = Replace(Replace(conFormula, "#1", beginRow), "#2", currentRow - 1)
            End With
            beginRow = currentRow + 1
        End If
    Next currentRow
    
    Application.Calculation = xlCalculationAutomatic

    MsgBox "指定された列に順次集計式を設定しました！", vbInformation
End Sub

Comments

[Shin_go]

回答ありがとうございます。
試したところ問題が解決しました！
丁寧に解説やご参考情報もいただきまして、とても勉強になりました。
ベストアンサーに選ばせていただきました。

Answer 3

B列の文字に”合計”がある行の値を加算して、A列の文字に”合計”がある行に加算したい。
対象となる列は、12,13,14,途中省略,46,47,48列である。
と解釈しました。
以下のようにしてください。

Option Explicit

Public Sub 合計算出()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim startRow As Long
    Dim wrow As Long
    Dim sumColumns As Variant
    ' シートを指定
    Set ws = ThisWorkbook.Sheets("収益状況")
    ' 合計する列を指定
    sumColumns = Array(12, 13, 14, 18, 19, 20, 21, 24, 25, 26, 27, 28, 29, 30, _
                       34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48)
    lastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
    startRow = 6
    For wrow = 6 To lastRow
        If ws.Cells(wrow, "A").Value Like "*合計*" Then
            Call set_total(ws, startRow, wrow, sumColumns)
            startRow = wrow + 1
        End If
    Next
    MsgBox "指定された合計の計算が完了しました！", vbInformation
End Sub
'指定範囲の合計を算出し、A列合計行に設定する
Private Sub set_total(ByRef ws As Worksheet, ByVal startRow As Long, ByVal sumRow As Long, ByRef sumColumns As Variant)
    Dim colIndex As Variant
    Dim totalSum As Double
    Dim currentRow As Long
    ' 各列を順次処理
    For Each colIndex In sumColumns
        ' 合計値を初期化
        totalSum = 0
        
        ' A列の「合計」行までの範囲をループ
        For currentRow = startRow To sumRow - 1 ' 合計行の直前まで
            ' B列が「合計」の場合のみ処理
            If ws.Cells(currentRow, "B").Value Like "*合計*" Then
                ' 該当列の値を加算
                totalSum = totalSum + ws.Cells(currentRow, colIndex).Value
            End If
        Next currentRow

        ' 合計値をA列の「合計」行に代入
        ws.Cells(sumRow, colIndex).Value = totalSum
    Next colIndex
    
End Sub

Comments

[Shin_go]

回答ありがとうございます。
ベストアンサーは別の方を選ばせていただきましたが、こちらの回答も非常に参考になりました。
大変助かりました、ありがとうございました。

Answer 4

こういうことですよね？

Sub Calc()
    Dim ws As Worksheet
    Dim i As Long
    Dim R As Long
    Dim C As Variant
    Dim Total() As Variant
    Dim Subtotal() As Variant
    
    ' シートを指定
    Set ws = ThisWorkbook.Sheets("収益状況")
    
    ' 合計する列を指定
    C = Array(12, 13, 14, 18, 19, 20, 21, 24, 25, 26, 27, 28, 29, 30, _
                       34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48)
                       
    ReDim Subtotal(UBound(C)) As Variant
    ReDim Total(UBound(C)) As Variant
    
    For i = LBound(C) To UBound(C)
        Subtotal(i) = 0
        Total(i) = 0
    Next i
    
    R = 6
    With ws
        Do While R < 41
            For i = LBound(C) To UBound(C)
                If InStr(.Cells(R, 1).Value, "合計") > 0 Then
                    'A列に｢合計｣の文字が含まれる場合
                    .Cells(R, C(i)).Value = Total(i)
                    Total(i) = 0
                ElseIf InStr(.Cells(R, 2).Value, "合計") > 0 Then
                    'B列に｢合計｣の文字が含まれる場合
                    .Cells(R, C(i)).Value = Subtotal(i)
                    Total(i) = Total(i) + Subtotal(i)
                    Subtotal(i) = 0
                Else
                    'いずれの文字が含まれない場合
                    Subtotal(i) = Subtotal(i) + .Cells(R, C(i)).Value
                End If
            Next i
            R = R + 1
        Loop
    End With
    
    MsgBox "指定された列に順次合計を代入しました！", vbInformation
End Sub

Comments

[Shin_go]

回答ありがとうございます。
ベストアンサーは別の方を選ばせていただきましたが、こちらの回答も非常に参考になりました。
大変助かりました、ありがとうございました。