エクセル VBAで色塗りについて教えてください

VBA初心者です。

例えばB列2行目から下に(1)～(7)までの番号を不規則に入力することにより
F列11～17行目に1セルずつ右へ色塗りをしていくにはどうプログラムをかいたらよいでしょうか？

番号によって、色塗りの行と色は決まっています。

(1)→11行目、黄色
(2)→12行目、青色
(3)→13行目、赤色
(4)→14行目、緑色
(5)→15行目、白色
(6)→16行目、黒色
(7)→17行目、茶色

また色塗りはF列からBD列までで終了です。
番号の入力回数の多いものが色塗りを早く終了できることになります。

VBAの本をみながら試行錯誤していましたが、うまくできず…
どなたか詳しい方、お力を貸してください。

No.4 ベストアンサー 回答者： mu2011 回答日時： 2012/03/15 23:18

NO2です。

文字列（仮にa～g）の対応例と入力ミスした場合はＢ列のDeleteでは行を確定できないのでＣ列に「x」を入力でリセットするようにしています。
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B2:B8")) Is Nothing Then
For Each ap In Target
Select Case ap
Case "a": clr = 6: arow = 0
Case "b": clr = 5: arow = 1
Case "c": clr = 3: arow = 2
Case "d": clr = 4: arow = 3
Case "e": clr = 2: arow = 4
Case "f": clr = 1: arow = 5
Case "g": clr = 9: arow = 6
Case Else: Exit Sub
End Select
For i = 0 To Columns("BD").Column - 6
With Range("F11").Offset(arow, i).Interior
If IsNull(.ColorIndex) Or .ColorIndex < 0 Then
.ColorIndex = clr
Exit For
End If
End With
Next
Next
Else
If Intersect(Target, Range("C2:C8")) Is Nothing Then Exit Sub
For Each ap In Target
If ap = "x" Then
Select Case ap.Offset(0, -1)
Case "a": arow = 0
Case "b": arow = 1
Case "c": arow = 2
Case "d": arow = 3
Case "e": arow = 4
Case "f": arow = 5
Case "g": arow = 6
End Select
For i = Columns("BD").Column - 6 To 0 Step -1
With Range("F11").Offset(arow, i).Interior
If .ColorIndex > 0 Then
.ColorIndex = xlNone
Application.EnableEvents = False
ap.Offset(0, -1).Resize(, 2).ClearContents
Application.EnableEvents = True
Exit For
End If
End With
Next
End If
Next
End If
End Sub

この回答へのお礼

今回も本当にありがとうございます。

文字列入力についてはバッチリ問題のないものでした。
すごいです。助かりました。
ただクリアになった時が"X”入力で、うまく作動せず…。

結果、文字列の入力回数をワークシートのCOUNTIF関数で計算し
その数字分のセルだけ右に色塗りした方がいいのでは？と思い
3／15「VBA　右へ1セルずつ色塗りするには」で再質問させていただきました。

もしよろしければ、そちらでの回答をいただけますと
（かなりずうずうしいですが）大変ありがたく思います。
頼りっぱなしで申し訳ありませんが、よろしくお願いします。

お礼日時：2012/03/17 09:11

No.3 回答者： tom04 回答日時： 2012/03/11 23:30

No.1です。

＞しかしやってみましたが、上手くいかず…。

とありますので・・・
当方の説明不足だと思います。

もう一度画像をUPしてみます。
今回はダミーではなくB2～B8セルに入れるデータをE列に表示しておきます。
色サンプルは同じ行のB列セルを塗りつぶしておくとして。

Private Sub CommandButton1_Click()
Dim i, j, k As Long
Application.ScreenUpdating = False
For i = 2 To 8
For k = 11 To 17
j = Cells(k, Columns.Count).End(xlToLeft).Column
If Cells(i, 2) = Cells(k, 5) And j <= 55 Then
With Cells(k, j + 1)
.Value = Cells(k, 5)
.Font.ColorIndex = Cells(k, 2).Interior.ColorIndex
.Interior.ColorIndex = Cells(k, 2).Interior.ColorIndex
End With
End If
Next k
Next i
Application.ScreenUpdating = True
End Sub

こんな感じではどうでしょうか？

今回もダメならごめんなさいね。m(_ _)m

この回答へのお礼

今回もありがとうございます。

ただコマンドボタン作成もよくわかっていない初心者のため
有効に使えず…申し訳ありません。

勉強不足です。ありがとうございました。

お礼日時：2012/03/17 08:59

No.2 回答者： mu2011 回答日時： 2012/03/11 09:29

イベントプロシージャ例です。

対象シートタブ上で右クリック→コードの表示→サンプルコードを貼り付けてお試しください。

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B2:B8")) Is Nothing Then Exit Sub
For Each ap In Target
If ap <> "" Or ap > 0 And ap < 8 Then
Select Case ap
Case 1: clr = 6
Case 2: clr = 5
Case 3: clr = 3
Case 4: clr = 4
Case 5: clr = 2
Case 6: clr = 1
Case 7: clr = 9
End Select
ap = ap - 1
For i = 0 To Columns("BD").Column - 6
With Range("F11").Offset(ap, i).Interior
If IsNull(.ColorIndex) Or .ColorIndex < 0 Then
.ColorIndex = clr
Exit For
End If
End With
Next
End If
Next
End Sub

この回答への補足

ありがとうございました。
貼り付けで上手く作動できました。

ただ2点、追加でおききしたいことがあります。

1　Case1～7の入力が数字ではなく文字になった場合、どうしたらよいでしょうか。
文字を別の列で数字におきかえようとしましたが、うまくできませんでした。

2　入力をクリアにした場合、色塗りもクリアにしたい場合は、どうしたらよいでしょうか。
　 今の状態ですと間違って入力した場合も、カウントされて色塗りになってしまうようです。

申し訳ありませんが、もう少しお力を貸してください。

補足日時：2012/03/11 21:59

No.1 回答者： tom04 回答日時： 2012/03/11 01:30

こんばんは！

一例です。

↓の画像のようにコマンドボタンを配置し、
色サンプルとしてB11～B17セルを塗りつぶしています。
（「白」は判らないので、灰色にしてみました）

ダミー（ストッパー）としてE11～E17セルにデータを入れています。
尚、色付とデータを入れるようにしています（塗りつぶしと同じフォント色）ので
最初からやる場合はデータをDeleteし（ダミーは残す）なおかつ色も消してください。

Private Sub CommandButton1_Click()
Dim i, j, k As Long
For i = 2 To 8
For k = 11 To 17
j = Cells(k, Columns.Count).End(xlToLeft).Column
If Cells(k, j + 1) = "" And j <= 55 Then
If Cells(k, 2) = Cells(i, 2) Then
With Cells(k, Columns.Count).End(xlToLeft).Offset(, 1)
.Value = 1
.Font.ColorIndex = Cells(k, 2).Interior.ColorIndex
.Interior.ColorIndex = Cells(k, 2).Interior.ColorIndex
End With
End If
End If
Next k
Next i
End Sub

こんな感じでどうでしょうか？
他に良い方法があればごめんなさいね。m(_ _)m

この回答へのお礼

ありがとうございました。
しかしやってみましたが、上手くいかず…。
でも勉強になりました。
ありがとうございます。

お礼日時：2012/03/11 21:46