ExcelVBA｜背景色ごとにセルの値を合計する

## 嫁さまからの依頼
嫁さま「Excelでさ、色の付いたセルの値だけ抜粋して合計するって、できないかな？」

嫁さま「品番が縦にズラーっと並んでてさ」

嫁さま「横に1月、2月、3月…って月ごとに管理されてて、月ごと・品番ごとの売上が入力されてるのね」

嫁さま「で、その時々で注目したいセルには色つけたりするんだけど」

嫁さま「その色つけたセルの値だけ合計したいんだよね」

嫁さま「色は複数色、使ったりもするんだけど」

嫁さま「できる？」

ぼく「ん、はい（…VBA触ったことないけど）」


## 完成したもの

サンプルの画像を載せてみます。赤枠のところに行ごとの合計値を出力するマクロです。
![2021-09-23_19h17_53 (1).jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/2071151/447878a3-32db-b917-eb39-f13147a5e559.jpeg)

マクロを実行すると…、
![2021-09-24_12h32_07.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/2071151/65dbe6cf-4a85-be34-54fc-a2560e2fe24b.jpeg)

こんな感じに、行ごと・色ごとの合計値が一括計算されます。


## 開発環境
- Windows10 64bit
- Excel 2016 


## 実装
コードの中身を紹介します。

### 計算ループ
```
    '''計算ループ準備
    Dim total(4) As Long
    Dim j, k As Integer
    j = 0
    k = 0
    
    '''計算ループ実行
    '行ループ
    For row = start_row To end_row
        
        '列ループ
        For column = firstMonthClm To lastMonthClm
        
            'カラーループ
            For j = 0 To colorNum
                
                If Cells(row, column).Interior.Color = colors(j) Then
                    total(j) = total(j) + Cells(row, column).Value
                End If
                
            Next j
            
        Next column
        
        For k = 0 To colorNum
            Cells(row, colorClms(k)).Value = total(k)
            total(k) = 0    '1行ごとにゼロクリア
        Next k
        
    Next row
    
```

for文を入れ子にして、行・列・複数色ごとにスキャンするようにしてます。
んで、If文で該当の色セルが見つかったら、そのセルの値を都度加算します。

色のスキャンはfor文じゃなくて、他にもっとやりようがあったかも、と感じている。

計算範囲は事前に取得してます（後述）
色情報は配列に代入しておいて、処理してますね。


### 計算範囲の取得
計算範囲はループ計算の前に取得してます。

    '宣言と初期化
    Dim row, column As Integer
    Dim start_row, end_row As Integer
    
    row = 0
    column = 0
        
    
    '''ユーザー設定の取得
    start_row = Cells(2, 3).Value   '計算範囲の開始行を取得する
    end_row = GetEndRow()
    Dim colors(4) As Long
    Dim colorClms(4) As Integer
    Dim colorNum As Integer
    Call GetColorsConfig(colors(), colorClms(), colorNum)
    
    
    Dim firstMonthClm As Integer
    Dim lastMonthClm As Integer
    Call GetCalcMonths(firstMonthClm, lastMonthClm)

ユーザー側が計算範囲を設定できるようにして、その設定を読み取るものです。
部分ごとに関数化していたりしてますが、その中身はコード全体として後述します。
読み取っている情報は下記の通り。

- 計算範囲の最初の行・列
- 最後の行・列
- 計算する色
- 計算結果の出力先の列


計算範囲の設定というのは下記みたいな感じ（ちょっとダサいけど…）
![user_config.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/2071151/87d07561-2bf8-47ee-dd3c-548ffb3238b1.jpeg)


計算範囲を示す「最初の列」「最後の行・列」は、”タグ”をシート内に置いてもらうことで対応してます（これもちょっとダサい…他に何かやり方ないかな…）
＜タグ＞
- End_Row: 最後の行
- First_Month: 最初の列
- Last_Month: 最後の列




## ソースコード全体
ソースコード全体です。
これだけマクロに書けば、実行可能です。

```
Option Explicit

'<使い方>
'開始行には､計算したい範囲の1番目の行を入力
'色は4つまで指定することができます
'指定の色でセルを塗りつぶし､出力先の列番号を入力
'計算範囲の最終行の下、A列に「End_Raw」を入力
'計算範囲の列範囲は「First_Month」「Last_Month」で指定
'

Sub CalculateColorBlock()

    '宣言と初期化
    Dim row, column As Integer
    Dim start_row, end_row As Integer
    
    row = 0
    column = 0
        
    
    '''ユーザー設定の取得
    start_row = Cells(2, 3).Value   '計算範囲の開始行を取得する
    end_row = GetEndRow()
    Dim colors(4) As Long
    Dim colorClms(4) As Integer
    Dim colorNum As Integer
    Call GetColorsConfig(colors(), colorClms(), colorNum)
    
    
    Dim firstMonthClm As Integer
    Dim lastMonthClm As Integer
    Call GetCalcMonths(firstMonthClm, lastMonthClm)
    
    
    '''計算ループ準備
    Dim total(4) As Long
    Dim j, k As Integer
    j = 0
    k = 0
    
    '''計算ループ実行
    '行ループ
    For row = start_row To end_row
        
        '列ループ
        For column = firstMonthClm To lastMonthClm
        
            'カラーループ
            For j = 0 To colorNum
                
                If Cells(row, column).Interior.Color = colors(j) Then
                    total(j) = total(j) + Cells(row, column).Value
                End If
                
            Next j
            
        Next column
        
        For k = 0 To colorNum
            Cells(row, colorClms(k)).Value = total(k)
            total(k) = 0    '1行ごとにゼロクリア
        Next k
        
    Next row
        
End Sub

    
'''ユーザー設定（セル色と計算結果の出力先）の取得
Sub GetColorsConfig(ByRef colors() As Long, ByRef colorClms() As Integer, ByRef colorNum As Integer)
    
    'ユーザー設定カラーを決定するセルを指定するためのオフセット
    Const columnOffset As Integer = 3
    Const rowOffset As Integer = 3
    
    Dim i As Integer
    Dim abc As String
    i = 0
    
    Do Until i > 4
        If Cells(i + rowOffset, columnOffset).Value <> 0 Then
            colors(i) = Cells(i + rowOffset, columnOffset).Interior.Color
            
            abc = Cells(i + rowOffset, columnOffset).Text
            colorClms(i) = ABCtoCLM(abc)
            i = i + 1
        Else
            colorNum = i - 1
            Exit Do
        End If
    Loop
          
End Sub


'''列を示すアルファベットを番号に変換
Function ABCtoCLM(ByVal abc As String) As Integer
    ABCtoCLM = Range(abc + "1").column
End Function


'''計算範囲（行の次元）を決定するマーキングを取得
Function GetEndRow() As Integer
    
    Dim endCell As Range
    
    Set endCell = Range("A:A").Find("End_Row")
    
    If (endCell Is Nothing) Then
        MsgBox "処理したい範囲の最終行下に「End_Row」を入力してね！（A列目限定）"
    End If
    
    GetEndRow = endCell.row - 1
End Function


'''計算範囲（列の次元）を決定するマーキングを取得
Sub GetCalcMonths(ByRef firstMonthClm As Integer, ByRef lastMonthClm As Integer)
    
    Dim firstMonthCell As Range
    Dim lastMonthCell As Range
    
    Set firstMonthCell = Cells.Find("First_Month")
    Set lastMonthCell = Cells.Find("Last_Month")
    
    If (firstMonthCell Is Nothing Or lastMonthCell Is Nothing) Then
        MsgBox "計算したい範囲を指定するために「First_Month」「Last_Month」を入力してね！"
    End If
    
    firstMonthClm = firstMonthCell.column
    lastMonthClm = lastMonthCell.column
    
End Sub

```

## 終わりに
嫁さま「すごーい！めっちゃ楽！」

嫁さま「わたしの給料1週間ぶん払ってもいい！」

ぼく「マジすか（良い商売だな）」

さすがにお金もらってないです。