VBAで条件付き書式設定

質問

エクセルの一覧表で2行目から4行ずつ上から商品名、商品コード、会社、商品項目とあって、列がAからXまであります。
以前、商品名ごとに自動で色づけしていた時に使っていたVBAです。
Sub 色分け()

Dim Target As Range

For Each Target In Range("b2:e2,b5:e5,b8:e8,b11:e11,b14:e14,b17:e17,b20:e20,b23:e23")
Select Case True
Case InStr(Target.Value, "〇〇") > 0
Target.Resize(4, 1).Interior.ColorIndex = 24
Case InStr(Target.Value, "△△") > 0
Target.Resize(4, 1).Interior.ColorIndex = 38
Case Else
Target.Resize(4, 1).Interior.ColorIndex = xlNone
End Select
Next

End Sub
この色付け条件を4行目の商品項目ごとに変更したいのですが、方法が分からないので教えてください。
なんかすぐ出来そうな気がするんですけど、丸2日やっても分かりませんでした。
よろしくお願いします。

回答No.5

n-jun · ベストアンサー

＃１＆＃２です。

ならば

Sub 色分け_2()

Dim Target As Range

For Each Target In Range("A5:X5,A11:X11,A17:X17,A23:X23")
Select Case True
Case InStr(Target.Value, "〇〇") > 0
Target.Offset(-3).Resize(4, 1).Interior.ColorIndex = 24
Case InStr(Target.Value, "△△") > 0
Target.Offset(-3).Resize(4, 1).Interior.ColorIndex = 38
Case Else
Target.Offset(-3).Resize(4, 1).Interior.ColorIndex = xlNone
End Select
Next

End Sub

こうゆう感じ？

お礼

ビンゴです。
こんな短時間にありがとうございます。
とっても助かりました。
良いお年を。

回答No.4

kagakusuki

Sub 色分け2()

Dim w As Long
Dim r As Long
Dim c As Long

w = Range("b2:x2").Cells.Count - 1
For r = 0 To 30 - 2 Step 4
For c = 0 To w
With Range("b2").Offset(r, c)
Select Case True
Case InStr(.Offset(3).Value, "〇〇") > 0
.Resize(4, 1).Interior.ColorIndex = 24
Case InStr(.Offset(3).Value, "△△") > 0
.Resize(4, 1).Interior.ColorIndex = 38
Case Else
.Resize(4, 1).Interior.ColorIndex = xlNone
End Select
End With
Next c
Next r

End Sub

回答No.3

kagakusuki

余り効率は良くありませんが、取り敢えずは以下の様なパターンでは如何でしょうか。

Sub 色分け()

Dim Target As Range

For Each Target In Range("b2:x2,b6:x6,b10:x10,b14:x14,b18:x18,b122:x22,b26:x26,b30:x30")
Select Case True
Case InStr(Target.Offset(3).Value, "〇〇") > 0
Target.Resize(4, 1).Interior.ColorIndex = 24
Case InStr(Target.Offset(3).Value, "△△") > 0
Target.Resize(4, 1).Interior.ColorIndex = 38
Case Else
Target.Resize(4, 1).Interior.ColorIndex = xlNone
End Select
Next

End Sub

回答No.2

n-jun

＃１です。

例えばＡ５～Ｘ５の範囲にある”商品項目”毎に
ColorIndexの３４番以降で色分けをするとしたら、

Sub try()
Dim myDic As Object
Dim r As Range

Set myDic = CreateObject("Scripting.Dictionary")

Cells.Interior.ColorIndex = xlNone

For Each r In Range("A5:X5")

If r.Value <> "" Then

If Not myDic.Exists(r.Value) Then
myDic(r.Value) = myDic.Count
End If

r.Offset(-3).Resize(4).Interior.ColorIndex = 34 + Val(myDic(r.Value))
End If

Next

Set myDic = Nothing

End Sub

こんな感じでしょうか。

補足

1列4行を一つの枠として、4行目が○○だったら1から4行目を全てを赤、8行目が△△だったら5から8行目すべてを青にしたいです。
説明不足で済みません。

回答No.1

n-jun

以前のコードもですけど、
商品項目毎に”何色”をつけていくようにするのかが
不明な気がしますけど？

ColorIndexプロパティ値一覧
http://www.relief.jp/itnote/archives/000482.php

補足

色は24とか38です。
Target.Resize(4, 1)をどうにかすると解決しそうなのですが、マイナスを付けてもエラーになるし、検索してもよく分かりません。