「アクティブセルの間だけ」その行に色を付ける方法を教えて下さい。
付ける色は何色でも構いません。
それも条件がありまして、
セルに何かしら色(塗りつぶしの色)が付いている場合は、
そのセルのみにおいて、その色を表示したいです。
また後から色をつけた場合も、後からつけたその色を優先して表示する仕様にしたいと思っています。
VBAが必要でしたら、
そのマクロコードを教えていただきたいです。
●添付した画像は例として、
B5がアクティブセルになっていますので5行目に色(灰色)をつけています。
ですが、D5セルは黄色で塗りつぶされているため、この黄色を優先して表示しています。
(※分かりやすいように5行目の幅を広くしています。)
※何か分かりにくいところがありましたら、
どうかこのページでコメントをお願いします。
まず、セルに元々ついている背景色のことを考えないとしたら、こんな感じになります。
Dim previous_row As Range Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not previous_row Is Nothing Then previous_row.Interior.Pattern = xlNone End If Target.EntireRow.Interior.Color = 16764108 Set previous_row = Target.EntireRow End Sub
以上のコードを、色を変えたいシートのマクロに貼り付けます。
後は、選択された行の背景色を変える前の色を保存、行の色を変えた後に復元。
別のセルが選択されたときに、行の色を元に戻し、個別のセルの色を復元。
という感じかな、と思いましたが、こんなところが気になりました。
で、セルに色を付ける方法を変えることで、対応したらどうでしょうか、という提案です。
「条件付き書式」は、セルの書式設定の書式に優先されます。
色を保存しておきたいセルには、セルの書式ではなく、条件付き書式で、以下のような設定をします。
数式には「=TRUE」、つまり、常に成立する、を指定して、書式で背景色を指定します。
すると、先に挙げたコードで、複数のセルを選択した場合、こんなような感じになります。
ただ私が色を付けたいセルというのは、G列、Q列、R列、S列、T列、U列でして、それも数千行とあります。
背景色を保存する対象が A~Z 列の範囲限定(このくらいなら、遅くない)として、こんな感じではどうでしょう。
Dim previous_row As Range Const BACKGROUND_COLOR = 16764108 Const MAX_COLUMN = 26 Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim backup_color() As Long If Not previous_row Is Nothing Then ReDim backup_color(1 To previous_row.Rows.Count, 1 To MAX_COLUMN) For r = 1 To previous_row.Rows.Count For c = 1 To MAX_COLUMN If previous_row.Cells(r, c).Interior.Color <> BACKGROUND_COLOR Then backup_color(r, c) = previous_row.Cells(r, c).Interior.Color Else backup_color(r, c) = -1 End If Next Next previous_row.Interior.Pattern = xlNone For r = 1 To previous_row.Rows.Count For c = 1 To MAX_COLUMN If backup_color(r, c) > 0 Then previous_row.Cells(r, c).Interior.Color = backup_color(r, c) End If Next Next End If ' これを入れておかないと、全選択とかすると、固まります If Target.Rows.Count > 50 Then Set previous_row = Nothing Exit Sub End If ReDim backup_color(1 To Target.Rows.Count, 1 To MAX_COLUMN) For r = 1 To Target.Rows.Count For c = 1 To MAX_COLUMN If Target.EntireRow.Cells(r, c).Interior.Pattern <> xlNone Then backup_color(r, c) = Target.EntireRow.Cells(r, c).Interior.Color Else backup_color(r, c) = -1 End If Next Next Target.EntireRow.Interior.Color = BACKGROUND_COLOR Set previous_row = Target.EntireRow For r = 1 To Target.Rows.Count For c = 1 To MAX_COLUMN If backup_color(r, c) > 0 Then Target.EntireRow.Cells(r, c).Interior.Color = backup_color(r, c) End If Next Next End Sub
やっつけ感が満載のコードですが、後で色を付けても大丈夫なのは確認しました。
後、選択したセルの行数が 50 を超えた場合には、処理を打ち切っています。
これをやらないと、シートのセルを全選択、とかすると、固まってしまうはずなので。
連続してセルを選択しても大丈夫なようには作ったのですが、複数のセルを飛び飛びに選択したときの動作はちょっと怪しいんです (´・ω・`)
一度【塗りつぶしなし】を選んでしまうと、
「塗りつぶしなしを色と見なして」しまい、塗りつぶし状態のセルが最優先されてしまうようです。
対応してみました。
Dim previous_row As Range Const BACKGROUND_COLOR = 16764108 Const MAX_COLUMN = 26 Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim backup_color() As Long If Not previous_row Is Nothing Then ReDim backup_color(1 To previous_row.Rows.Count, 1 To MAX_COLUMN) For r = 1 To previous_row.Rows.Count For c = 1 To MAX_COLUMN If previous_row.Cells(r, c).Interior.Color <> BACKGROUND_COLOR And _ previous_row.Cells(r, c).Interior.Pattern <> xlNone Then backup_color(r, c) = previous_row.Cells(r, c).Interior.Color Else backup_color(r, c) = -1 End If Next Next previous_row.Interior.Pattern = xlNone For r = 1 To previous_row.Rows.Count For c = 1 To MAX_COLUMN If backup_color(r, c) > 0 Then previous_row.Cells(r, c).Interior.Color = backup_color(r, c) End If Next Next End If ' これを入れておかないと、全選択とかすると、固まります If Target.Rows.Count > 50 Then Set previous_row = Nothing Exit Sub End If ReDim backup_color(1 To Target.Rows.Count, 1 To MAX_COLUMN) For r = 1 To Target.Rows.Count For c = 1 To MAX_COLUMN If Target.EntireRow.Cells(r, c).Interior.Pattern <> xlNone Then backup_color(r, c) = Target.EntireRow.Cells(r, c).Interior.Color Else backup_color(r, c) = -1 End If Next Next Target.EntireRow.Interior.Color = BACKGROUND_COLOR Set previous_row = Target.EntireRow For r = 1 To Target.Rows.Count For c = 1 To MAX_COLUMN If backup_color(r, c) > 0 Then Target.EntireRow.Cells(r, c).Interior.Color = backup_color(r, c) End If Next Next End Sub
選択したセル全てを一括で塗りつぶしたいと考えているのですが、
もし解決法が分かりましたら教えていただきたいです。
ループの回し方を変えてみました。
前のコードに比べると、ちょっともっさりした感じがしますが、何となく動きます。
Dim previous_row As Range Const BACKGROUND_COLOR = 16764108 Const MAX_COLUMN = 26 Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim backup_color() As Long If Not previous_row Is Nothing Then ReDim backup_color(1 To previous_row.Count, 1 To MAX_COLUMN) i = 1 For Each r In previous_row For c = 1 To MAX_COLUMN If r.EntireRow.Cells(1, c).Interior.Color <> BACKGROUND_COLOR And _ r.EntireRow.Cells(1, c).Interior.Pattern <> xlNone Then backup_color(i, c) = r.EntireRow.Cells(1, c).Interior.Color Else backup_color(i, c) = -1 End If Next i = i + 1 If i > 50 Then ' 恐がってます (´・ω・`) Debug.print "exit (1)" Exit Sub End If Next For Each r In previous_row r.EntireRow.Interior.Pattern = xlNone next i = 1 For Each r In previous_row For c = 1 To MAX_COLUMN If backup_color(i, c) > 0 Then r.EntireRow.Cells(1, c).Interior.Color = backup_color(i, c) End If Next i = i + 1 If i > 50 Then ' 恐がってます (´・ω・`) Debug.print "exit (2)" Exit Sub End If Next End If ' これを入れておかないと、全選択とかすると、固まります If Target.Count > 50 Then Set previous_row = Nothing Exit Sub End If ReDim backup_color(1 To Target.Count, 1 To MAX_COLUMN) i = 1 For Each r In Target For c = 1 To MAX_COLUMN 'Debug.Print Target.EntireRow.Cells(r, c).Interior.Color If r.EntireRow.Cells(1, c).Interior.Pattern <> xlNone Then backup_color(i, c) = r.EntireRow.Cells(1, c).Interior.Color Else backup_color(i, c) = -1 End If Next i = i + 1 If i > 50 Then ' 恐がってます (´・ω・`) Debug.print "exit (3)" Exit Sub End If Next Target.EntireRow.Interior.Color = BACKGROUND_COLOR Set previous_row = Target i = 1 For Each r In Target For c = 1 To MAX_COLUMN If backup_color(i, c) > 0 Then r.EntireRow.Cells(1, c).Interior.Color = backup_color(i, c) End If Next i = i + 1 If i > 50 Then ' 恐がってます (´・ω・`) Debug.print "exit (4)" Exit Sub End If Next End Sub
「恐がってます (´・ω・`)」のコメントを入れたところは、無くても大丈夫だと思うのですが、編集中にマクロが固まると、かなり悲しい思いをするので、残しておいた方が良いと思います。
Debug.print じゃなくて、Msgbox の方が良かったかも。
まず、セルに元々ついている背景色のことを考えないとしたら、こんな感じになります。
Dim previous_row As Range Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not previous_row Is Nothing Then previous_row.Interior.Pattern = xlNone End If Target.EntireRow.Interior.Color = 16764108 Set previous_row = Target.EntireRow End Sub
以上のコードを、色を変えたいシートのマクロに貼り付けます。
後は、選択された行の背景色を変える前の色を保存、行の色を変えた後に復元。
別のセルが選択されたときに、行の色を元に戻し、個別のセルの色を復元。
という感じかな、と思いましたが、こんなところが気になりました。
で、セルに色を付ける方法を変えることで、対応したらどうでしょうか、という提案です。
「条件付き書式」は、セルの書式設定の書式に優先されます。
色を保存しておきたいセルには、セルの書式ではなく、条件付き書式で、以下のような設定をします。
数式には「=TRUE」、つまり、常に成立する、を指定して、書式で背景色を指定します。
すると、先に挙げたコードで、複数のセルを選択した場合、こんなような感じになります。
ただ私が色を付けたいセルというのは、G列、Q列、R列、S列、T列、U列でして、それも数千行とあります。
背景色を保存する対象が A~Z 列の範囲限定(このくらいなら、遅くない)として、こんな感じではどうでしょう。
Dim previous_row As Range Const BACKGROUND_COLOR = 16764108 Const MAX_COLUMN = 26 Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim backup_color() As Long If Not previous_row Is Nothing Then ReDim backup_color(1 To previous_row.Rows.Count, 1 To MAX_COLUMN) For r = 1 To previous_row.Rows.Count For c = 1 To MAX_COLUMN If previous_row.Cells(r, c).Interior.Color <> BACKGROUND_COLOR Then backup_color(r, c) = previous_row.Cells(r, c).Interior.Color Else backup_color(r, c) = -1 End If Next Next previous_row.Interior.Pattern = xlNone For r = 1 To previous_row.Rows.Count For c = 1 To MAX_COLUMN If backup_color(r, c) > 0 Then previous_row.Cells(r, c).Interior.Color = backup_color(r, c) End If Next Next End If ' これを入れておかないと、全選択とかすると、固まります If Target.Rows.Count > 50 Then Set previous_row = Nothing Exit Sub End If ReDim backup_color(1 To Target.Rows.Count, 1 To MAX_COLUMN) For r = 1 To Target.Rows.Count For c = 1 To MAX_COLUMN If Target.EntireRow.Cells(r, c).Interior.Pattern <> xlNone Then backup_color(r, c) = Target.EntireRow.Cells(r, c).Interior.Color Else backup_color(r, c) = -1 End If Next Next Target.EntireRow.Interior.Color = BACKGROUND_COLOR Set previous_row = Target.EntireRow For r = 1 To Target.Rows.Count For c = 1 To MAX_COLUMN If backup_color(r, c) > 0 Then Target.EntireRow.Cells(r, c).Interior.Color = backup_color(r, c) End If Next Next End Sub
やっつけ感が満載のコードですが、後で色を付けても大丈夫なのは確認しました。
後、選択したセルの行数が 50 を超えた場合には、処理を打ち切っています。
これをやらないと、シートのセルを全選択、とかすると、固まってしまうはずなので。
連続してセルを選択しても大丈夫なようには作ったのですが、複数のセルを飛び飛びに選択したときの動作はちょっと怪しいんです (´・ω・`)
一度【塗りつぶしなし】を選んでしまうと、
「塗りつぶしなしを色と見なして」しまい、塗りつぶし状態のセルが最優先されてしまうようです。
対応してみました。
Dim previous_row As Range Const BACKGROUND_COLOR = 16764108 Const MAX_COLUMN = 26 Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim backup_color() As Long If Not previous_row Is Nothing Then ReDim backup_color(1 To previous_row.Rows.Count, 1 To MAX_COLUMN) For r = 1 To previous_row.Rows.Count For c = 1 To MAX_COLUMN If previous_row.Cells(r, c).Interior.Color <> BACKGROUND_COLOR And _ previous_row.Cells(r, c).Interior.Pattern <> xlNone Then backup_color(r, c) = previous_row.Cells(r, c).Interior.Color Else backup_color(r, c) = -1 End If Next Next previous_row.Interior.Pattern = xlNone For r = 1 To previous_row.Rows.Count For c = 1 To MAX_COLUMN If backup_color(r, c) > 0 Then previous_row.Cells(r, c).Interior.Color = backup_color(r, c) End If Next Next End If ' これを入れておかないと、全選択とかすると、固まります If Target.Rows.Count > 50 Then Set previous_row = Nothing Exit Sub End If ReDim backup_color(1 To Target.Rows.Count, 1 To MAX_COLUMN) For r = 1 To Target.Rows.Count For c = 1 To MAX_COLUMN If Target.EntireRow.Cells(r, c).Interior.Pattern <> xlNone Then backup_color(r, c) = Target.EntireRow.Cells(r, c).Interior.Color Else backup_color(r, c) = -1 End If Next Next Target.EntireRow.Interior.Color = BACKGROUND_COLOR Set previous_row = Target.EntireRow For r = 1 To Target.Rows.Count For c = 1 To MAX_COLUMN If backup_color(r, c) > 0 Then Target.EntireRow.Cells(r, c).Interior.Color = backup_color(r, c) End If Next Next End Sub
選択したセル全てを一括で塗りつぶしたいと考えているのですが、
もし解決法が分かりましたら教えていただきたいです。
ループの回し方を変えてみました。
前のコードに比べると、ちょっともっさりした感じがしますが、何となく動きます。
Dim previous_row As Range Const BACKGROUND_COLOR = 16764108 Const MAX_COLUMN = 26 Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim backup_color() As Long If Not previous_row Is Nothing Then ReDim backup_color(1 To previous_row.Count, 1 To MAX_COLUMN) i = 1 For Each r In previous_row For c = 1 To MAX_COLUMN If r.EntireRow.Cells(1, c).Interior.Color <> BACKGROUND_COLOR And _ r.EntireRow.Cells(1, c).Interior.Pattern <> xlNone Then backup_color(i, c) = r.EntireRow.Cells(1, c).Interior.Color Else backup_color(i, c) = -1 End If Next i = i + 1 If i > 50 Then ' 恐がってます (´・ω・`) Debug.print "exit (1)" Exit Sub End If Next For Each r In previous_row r.EntireRow.Interior.Pattern = xlNone next i = 1 For Each r In previous_row For c = 1 To MAX_COLUMN If backup_color(i, c) > 0 Then r.EntireRow.Cells(1, c).Interior.Color = backup_color(i, c) End If Next i = i + 1 If i > 50 Then ' 恐がってます (´・ω・`) Debug.print "exit (2)" Exit Sub End If Next End If ' これを入れておかないと、全選択とかすると、固まります If Target.Count > 50 Then Set previous_row = Nothing Exit Sub End If ReDim backup_color(1 To Target.Count, 1 To MAX_COLUMN) i = 1 For Each r In Target For c = 1 To MAX_COLUMN 'Debug.Print Target.EntireRow.Cells(r, c).Interior.Color If r.EntireRow.Cells(1, c).Interior.Pattern <> xlNone Then backup_color(i, c) = r.EntireRow.Cells(1, c).Interior.Color Else backup_color(i, c) = -1 End If Next i = i + 1 If i > 50 Then ' 恐がってます (´・ω・`) Debug.print "exit (3)" Exit Sub End If Next Target.EntireRow.Interior.Color = BACKGROUND_COLOR Set previous_row = Target i = 1 For Each r In Target For c = 1 To MAX_COLUMN If backup_color(i, c) > 0 Then r.EntireRow.Cells(1, c).Interior.Color = backup_color(i, c) End If Next i = i + 1 If i > 50 Then ' 恐がってます (´・ω・`) Debug.print "exit (4)" Exit Sub End If Next End Sub
「恐がってます (´・ω・`)」のコメントを入れたところは、無くても大丈夫だと思うのですが、編集中にマクロが固まると、かなり悲しい思いをするので、残しておいた方が良いと思います。
Debug.print じゃなくて、Msgbox の方が良かったかも。
どかどかコードを貼り付けてしまったので、分かりにくくなって、すみませんでした。
なんとか希望されてるものに、近いものになって、ホッとしました :-)
どうでも良いことですが、VBA って、苦手で。
できれば、一生、触らずに済ませたいんですが、そうも行かないというか、便利な場面があることが分かってるだけに、たまにいじります。
今回は、ぼくも、良い勉強をさせていただきました。
加えて、過分なポイントをいただき、ありがとうございました。
a-kuma3 さんへ
いえ、とても分かりやすいコードの書き方(背景が黒のスペースにコードがまとまって書かれているので)ですよ。
しかもまさに理想通りの動作をしてくれるコードで、とても嬉しいです!
a-kuma3さんがVBA苦手って、すごく謙虚ですね。
能ある鷹は爪隠す、と言いますかなんか凄すぎて単純に尊敬してしまいます。
もし、また自分を見かけることがありましたら今後ともよろしくお願いいたします。
なんかもっとこんな難しいことしなくても条件付きセルにして、値があったら色をつけるとかの設定がありますよ。
「条件付きセル」ですね。
osはwindowsってことでいいですか?
かずきち。 さんへ
参考URLを教えていただきまして、ありがとうございます。
条件付き書式は使う場面も多いと思いますので、
知ってると何かと役に立ちそうですね。
私の場合ずっと使わないと、条件付き書式の書き方って意外と忘れてしまうので
今後のためにブックマークさせていただきました。
ありがとうございます。
どかどかコードを貼り付けてしまったので、分かりにくくなって、すみませんでした。
2014/10/12 20:45:27なんとか希望されてるものに、近いものになって、ホッとしました :-)
どうでも良いことですが、VBA って、苦手で。
できれば、一生、触らずに済ませたいんですが、そうも行かないというか、便利な場面があることが分かってるだけに、たまにいじります。
今回は、ぼくも、良い勉強をさせていただきました。
加えて、過分なポイントをいただき、ありがとうございました。
a-kuma3 さんへ
2014/10/12 21:40:30いえ、とても分かりやすいコードの書き方(背景が黒のスペースにコードがまとまって書かれているので)ですよ。
しかもまさに理想通りの動作をしてくれるコードで、とても嬉しいです!
a-kuma3さんがVBA苦手って、すごく謙虚ですね。
能ある鷹は爪隠す、と言いますかなんか凄すぎて単純に尊敬してしまいます。
もし、また自分を見かけることがありましたら今後ともよろしくお願いいたします。