VBA 右へ1セルずつ色塗りするには

質問

再質問です。
VBAでの色塗りに苦戦しています。

例えば、B列とD列にランダムに下記(1)～(7)の文字列が配列しています。

COUNTIF関数によって
それぞれの文字列の数をカウントします。

(1)みかん　　3
(2)サイダー　2
(3)いちご　　 6　
(4)キウイ　　 8
(5)なし　　　　1
(6)ぶどう　　 4
(7)チョコ　　　3

文字列の数によって、1セルずつ右に色塗りをしたいのです。
出発点、色は下記の通り、H列からBA列で色塗り終了です。
入力によって色塗りはどんどん右にのびていくことになりますが
BA列に到達してからは、それ以上入力しても反映させません。

(1)みかん　 →H列11行目、黄色
(2)サイダー →H列12行目、水色
(3)トマト　　 →H列13行目、赤色
(4)キウイ　 →H列14行目、緑色
(5)なし　　 →H列15行目、白色
(6)ぶどう　 →H列16行目、紫色
(7)チョコ　 →H列17行目、茶色

以上、よろしくお願いします。

回答No.2

tom04

No.1です！
たびたびごめんなさい。

前回は色付だけでしたが、実際は色を消すマクロも必要だと思いますので
もう一度コードを載せてみます。

今回は「コマンドボタン」にしていません。

Sub 色付()
Dim i, j, k, L As Long
For k = 11 To 17
For i = 1 To 7
j = Cells(k, Columns.Count).End(xlToLeft).Column + 1
If Cells(k, 7) = Cells(i, 2) And j <= 53 Then
L = j + Cells(i, 4) - 1
If L > 53 Then
L = 53
End If
With Range(Cells(k, j), Cells(k, L))
.Value = 1
.Font.ColorIndex = Cells(k, 7).Interior.ColorIndex
.Interior.ColorIndex = Cells(k, 7).Interior.ColorIndex
End With
End If
Next i
Next k
End Sub

Sub リセット()
If MsgBox("色を削除しますか？", vbYesNo) = vbYes Then
With Range("H11:BA17")
.ClearContents
.Interior.ColorIndex = xlNone
End With
Else
Exit Sub
End If
End Sub

※　前回同様、G列にはB列のデータを入力（順番は変わっても問題ありません）しておき、
塗りつぶしたい色でセルを塗りつぶしておきます。

参考になりますかね？m(_ _)m

回答No.1

tom04

こんばんは！
前回似たような質問に投稿した者です。

＞文字列の数によって、1セルずつ右に色塗りをしたいのです・・・

の部分で、解釈が違っていたらごめんなさい。

B・D列のセル配置が判らないので勝手に↓の画像の配置にしています。
コマンドボタンを配置して、クリックするとD列の数だけ色がつくようにしてみました。

Private Sub CommandButton1_Click()
Dim i, j, k, L As Long
For k = 11 To 17
For i = 1 To 7
j = Cells(k, Columns.Count).End(xlToLeft).Column + 1
If Cells(k, 7) = Cells(i, 2) And j <= 53 Then
L = j + Cells(i, 4) - 1
If L > 53 Then
L = 53
End If
With Range(Cells(k, j), Cells(k, L))
.Value = 1
.Font.ColorIndex = Cells(k, 7).Interior.ColorIndex
.Interior.ColorIndex = Cells(k, 7).Interior.ColorIndex
End With
End If
Next i
Next k
End Sub

※　「白」は塗りつぶしているかどうか判らないので「灰色25％」にしています。
※　F列にA列データを入力・セル色は色サンプルとして塗りつぶしています。
尚、H列以降のセルには「1」のデータを入れていますので、最初からやり直す場合は
データを削除し、「セルの塗りつぶし」なし
にして行ってみてください。

外していたらごめんなさいね。m(_ _)m