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ベストアンサー
- 回答日時:
NO2です。
文字列(仮にa~g)の対応例と入力ミスした場合はB列のDeleteでは行を確定できないのでC列に「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セルずつ色塗りするには」で再質問させていただきました。
もしよろしければ、そちらでの回答をいただけますと
(かなりずうずうしいですが)大変ありがたく思います。
頼りっぱなしで申し訳ありませんが、よろしくお願いします。
No.3
- 回答日時:
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
今回もありがとうございます。
ただコマンドボタン作成もよくわかっていない初心者のため
有効に使えず…申し訳ありません。
勉強不足です。ありがとうございました。
No.2
- 回答日時:
イベントプロシージャ例です。
対象シートタブ上で右クリック→コードの表示→サンプルコードを貼り付けてお試しください。
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 入力をクリアにした場合、色塗りもクリアにしたい場合は、どうしたらよいでしょうか。
今の状態ですと間違って入力した場合も、カウントされて色塗りになってしまうようです。
申し訳ありませんが、もう少しお力を貸してください。
No.1
- 回答日時:
こんばんは!
一例です。
↓の画像のようにコマンドボタンを配置し、
色サンプルとして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
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
関連するカテゴリからQ&Aを探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・14歳の自分に衝撃の事実を告げてください
- ・架空の映画のネタバレレビュー
- ・「お昼の放送」の思い出
- ・昨日見た夢を教えて下さい
- ・ちょっと先の未来クイズ第4問
- ・【大喜利】【投稿~10/21(月)】買ったばかりの自転車を分解してひと言
- ・メモのコツを教えてください!
- ・CDの保有枚数を教えてください
- ・ホテルを選ぶとき、これだけは譲れない条件TOP3は?
- ・家・車以外で、人生で一番奮発した買い物
- ・人生最悪の忘れ物
- ・【コナン30周年】嘘でしょ!?と思った○○周年を教えて【ハルヒ20周年】
- ・ハマっている「お菓子」を教えて!
- ・最近、いつ泣きましたか?
- ・夏が終わったと感じる瞬間って、どんな時?
- ・10秒目をつむったら…
- ・人生のプチ美学を教えてください!!
- ・あなたの習慣について教えてください!!
- ・牛、豚、鶏、どれか一つ食べられなくなるとしたら?
- ・都道府県穴埋めゲーム
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
Excelの入力規則で2列表示したい
-
複数の文字列のいずれかが含ま...
-
SUMに含まれる範囲から特定のセ...
-
数式が入ったセルを含めて、数...
-
スペースとスペースの間の文字...
-
エクセルで合計欄を結合し、左...
-
エクセルで表示されている数字...
-
Excel上でのデータ数字が連番で...
-
列の数字に100をかけたい
-
エクセルで1列全部10倍したい
-
エクセルで公平にチーム分けす...
-
エクセル:横長の表を改行して...
-
別のセルに値が入力されたら、...
-
エクセルで小数を含む数値の抽出
-
エクセルでセルの値分の個数の...
-
EXCELの特定セルを編集不可・コ...
-
Excelでの検索結果を含む行だけ...
-
時間を「昼間」と「夜間」に分...
-
エクセルで、ある1つの列を複...
-
Excelのセル内文字の並び替えに...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Excelの入力規則で2列表示したい
-
複数の文字列のいずれかが含ま...
-
SUMに含まれる範囲から特定のセ...
-
数式が入ったセルを含めて、数...
-
Excel上でのデータ数字が連番で...
-
スペースとスペースの間の文字...
-
エクセルで表示されている数字...
-
エクセル:横長の表を改行して...
-
列の数字に100をかけたい
-
別のセルに値が入力されたら、...
-
エクセルで1列全部10倍したい
-
エクセルでセルの値分の個数の...
-
Excelのセル内文字の並び替えに...
-
エクセルで曜日に応じた文字を...
-
エクセルで小数を含む数値の抽出
-
エクセルのsumifでかけ算してか...
-
時間を「昼間」と「夜間」に分...
-
エクセルで、毎日の走行距離(...
-
アルファベットを含む数をエク...
-
EXCELのハイホン区切りの数字並...
おすすめ情報