嫁さまからの依頼
嫁さま「Excelでさ、色の付いたセルの値だけ抜粋して合計するって、できないかな？」
嫁さま「品番が縦にズラーっと並んでてさ」
嫁さま「横に1月、2月、3月…って月ごとに管理されてて、月ごと・品番ごとの売上が入力されてるのね」
嫁さま「で、その時々で注目したいセルには色つけたりするんだけど」
嫁さま「その色つけたセルの値だけ合計したいんだよね」
嫁さま「色は複数色、使ったりもするんだけど」
嫁さま「できる？」
ぼく「ん、はい（…VBA触ったことないけど）」
完成したもの
サンプルの画像を載せてみます。赤枠のところに行ごとの合計値を出力するマクロです。
マクロを実行すると…、
こんな感じに、行ごと・色ごとの合計値が一括計算されます。
開発環境
- 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)
ユーザー側が計算範囲を設定できるようにして、その設定を読み取るものです。
部分ごとに関数化していたりしてますが、その中身はコード全体として後述します。
読み取っている情報は下記の通り。
- 計算範囲の最初の行・列
- 最後の行・列
- 計算する色
- 計算結果の出力先の列
計算範囲の設定というのは下記みたいな感じ（ちょっとダサいけど…）
計算範囲を示す「最初の列」「最後の行・列」は、”タグ”をシート内に置いてもらうことで対応してます（これもちょっとダサい…他に何かやり方ないかな…）
＜タグ＞
- 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週間ぶん払ってもいい！」
ぼく「マジすか（良い商売だな）」
さすがにお金もらってないです。