こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

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

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

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

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

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

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

といった感じです。

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

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

投稿日時 - 2018-03-19 12:50:45

QNo.9479461

すぐに回答ほしいです

質問者が選んだベストアンサー

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

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

投稿日時 - 2018-03-19 17:35:17

お礼

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

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

投稿日時 - 2018-03-22 10:19:57

ANo.2

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.1

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

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

投稿日時 - 2018-03-19 13:11:54

補足

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

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

>色を別ける条件があればそれも教えてください。
投入という列に数字が入力されると、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

投稿日時 - 2018-03-19 14:35:11