VBAで色つきセルの数値足し算

質問

セルの色で足し算をするマクロについて教えて下さい。

添付画像のようなシートがある場合
マクロを実行するとその実行した日と同じ日付（2018/3/19）の
測定と書いてある列（S列）の数を計算をしたいです。

その際色ごとに足し算をしてその結果をメッセージボックスで表示したいです。

ピンク5個
緑11個
黄色5個
青1個
このような形です。

さらに次の日（2018/3/20）の残数も色ごとに足して
メッセージで表示したいです。

ピンク残りは6個
緑残りは4個
黄色残りは5個
青残りは2個

といった感じです。

計算する行は9行目から20行目までで
列の形は4列で1日の表示をしてあります。

どうか宜しくお願いします。

回答No.2

mt2015 · ベストアンサー

ColorIndexだけでは色名が解りませんので、色名情報を作業列に持ちましょう。
添付の例ではCV列を作業列として各行の色の名前を入れておきます。
で、サンプルコードです。

Sub Sample()
　　nCol = Rows("2:2").Find(What:=Int(Now())).Column + 1
　　Set todayDic = CreateObject("Scripting.Dictionary")
　　Set nextDic = CreateObject("Scripting.Dictionary")
　　For i = 9 To Cells(Rows.Count, "CV").End(xlUp).Row
　　　　sColor = Cells(i, "CV")
　　　　nDataToday = Cells(i, nCol).Value + 0
　　　　nDataNext = Cells(i, nCol + 3).Value + 0
　　　　If Not todayDic.exists(sColor) Then
　　　　　　todayDic.Add sColor, nDataToday
　　　　　　nextDic.Add sColor, nDataNext
　　　　Else
　　　　　　todayDic(sColor) = todayDic(sColor) + nDataToday
　　　　　　nextDic(sColor) = nextDic(sColor) + nDataNext
　　　　End If
　　Next i
　　sMessToday = "本日" & vbCrLf
　　sMessNext = "翌日" & vbCrLf
　　todayKey = todayDic.keys
　　todayItem = todayDic.items
　　nextItem = nextDic.items
　　For j = 0 To UBound(todayKey)
　　　　sMessToday = sMessToday & todayKey(j) & todayItem(j) & "個" & vbCrLf
　　　　sMessNext = sMessNext & todayKey(j) & "残りは" & nextItem(j) & "個" & vbCrLf
　　Next j
　　MsgBox sMessToday & "------" & vbCrLf & sMessNext
End Sub

手抜きコードですので、変数の宣言もしていませんし、本日の日付が無い場合、エラーになります。

お礼

お礼が遅くなり申し訳ありません。

頂いたコードを試した結果目的のことが行えました。
本当にありがとうございます。

回答No.1

mt2015

Excelは色で処理を別けるのが苦手です。
この色は、塗りつぶしで付けていますか？条件付き書式ですか？

色を別ける条件があればそれも教えてください。
また、Excelのバージョンは何でしょう。

補足

>この色は、塗りつぶしで付けていますか？条件付き書式ですか？

下記のコードで色を付けています。

＞色を別ける条件があればそれも教えてください。
投入という列に数字が入力されると、B列の塗りつぶしの色を反映して同じ色で4日間（休日はとばす）を塗りつぶすコードです。

＞Excelのバージョンは何でしょう。
2010です。

宜しくお願い致します。

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Dim myRange As Range
Dim l As Long
Dim Y As Long
l = Target.Row
Y = Cells(l, 2).Interior.Color

Const ColsUnit = 4 '1日当たりの列数
Const ClearDays = 10 '空欄の時に該当行の背景色を消す日数
Const MyColor = 5287936 '背景色

With ThisWorkbook.ActiveSheet
If ((Target.Column Mod ColsUnit = 1) And _
(Target.Column > 5)) Then
If ((Target.Value > 0) And IsNumeric(Target.Value)) Then
nCol = Target.Column + 1
nCount = 0
Do While nCount < 16
If Cells(2, nCol).Interior.ColorIndex <> 38 Then
If nCount = 0 Then
Set myRange = Range(Cells(Target.Row, nCol), Cells(Target.Row, nCol + 3))
Else
Set myRange = Union(myRange, Range(Cells(Target.Row, nCol), Cells(Target.Row, nCol + 3)))
End If
nCount = nCount + 4
End If
nCol = nCol + 4
Loop

myRange.Interior.Color = Y
Else
Set myRange = _
Range(.Cells(Target.Row, Target.Column + 1), _
.Cells(Target.Row, Target.Column + (ClearDays * ColsUnit)))
myRange.Interior.Pattern = xlNone
End If
End If
End With

End Sub