id:egaosaiko
ポイントあり1000ptベストアンサーあり
コンピュータ

1412872134 エクセル2007(Excel2007)で、

｢アクティブセルの間だけ｣その行に色を付ける方法を教えて下さい。
付ける色は何色でも構いません。


それも条件がありまして、
セルに何かしら色(塗りつぶしの色)が付いている場合は、
そのセルのみにおいて、その色を表示したいです。

また後から色をつけた場合も、後からつけたその色を優先して表示する仕様にしたいと思っています。


VBAが必要でしたら、
そのマクロコードを教えていただきたいです。



●添付した画像は例として、
B5がアクティブセルになっていますので5行目に色(灰色)をつけています。
ですが、D5セルは黄色で塗りつぶされているため、この黄色を優先して表示しています。
(※分かりやすいように5行目の幅を広くしています。)





※何か分かりにくいところがありましたら、
どうかこのページでコメントをお願いします。

回答の条件
  • 1人3回まで
  • 登録：
  • 終了：2014/10/12 19:55:38
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

ベストアンサー

id:a-kuma3 No.1

回答回数4974ベストアンサー獲得回数2154

ポイント1000pt

まず、セルに元々ついている背景色のことを考えないとしたら、こんな感じになります。

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

以上のコードを、色を変えたいシートのマクロに貼り付けます。

後は、選択された行の背景色を変える前の色を保存、行の色を変えた後に復元。
別のセルが選択されたときに、行の色を元に戻し、個別のセルの色を復元。
という感じかな、と思いましたが、こんなところが気になりました。

  • 対象の列の数を制限しないと、遅くなりそう
  • セルを複数選択した場合には、どうしようか

で、セルに色を付ける方法を変えることで、対応したらどうでしょうか、という提案です。
「条件付き書式」は、セルの書式設定の書式に優先されます。
色を保存しておきたいセルには、セルの書式ではなく、条件付き書式で、以下のような設定をします。
f:id:a-kuma3:20141010213323p:image
数式には「=TRUE」、つまり、常に成立する、を指定して、書式で背景色を指定します。

すると、先に挙げたコードで、複数のセルを選択した場合、こんなような感じになります。
f:id:a-kuma3:20141010213324j:image


追記です。

ただ私が色を付けたいセルというのは、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 の方が良かったかも。

他11件のコメントを見る
id:a-kuma3

どかどかコードを貼り付けてしまったので、分かりにくくなって、すみませんでした。
なんとか希望されてるものに、近いものになって、ホッとしました　:-)

どうでも良いことですが、VBA って、苦手で。
できれば、一生、触らずに済ませたいんですが、そうも行かないというか、便利な場面があることが分かってるだけに、たまにいじります。
今回は、ぼくも、良い勉強をさせていただきました。
加えて、過分なポイントをいただき、ありがとうございました。

2014/10/12 20:45:27
id:egaosaiko


a-kuma3 さんへ


いえ、とても分かりやすいコードの書き方(背景が黒のスペースにコードがまとまって書かれているので)ですよ。
しかもまさに理想通りの動作をしてくれるコードで、とても嬉しいです!


a-kuma3さんがVBA苦手って、すごく謙虚ですね。
能ある鷹は爪隠す、と言いますかなんか凄すぎて単純に尊敬してしまいます。


もし、また自分を見かけることがありましたら今後ともよろしくお願いいたします。

2014/10/12 21:40:30

その他の回答（1件）

id:a-kuma3 No.1

回答回数4974ベストアンサー獲得回数2154ここでベストアンサー

ポイント1000pt

まず、セルに元々ついている背景色のことを考えないとしたら、こんな感じになります。

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

以上のコードを、色を変えたいシートのマクロに貼り付けます。

後は、選択された行の背景色を変える前の色を保存、行の色を変えた後に復元。
別のセルが選択されたときに、行の色を元に戻し、個別のセルの色を復元。
という感じかな、と思いましたが、こんなところが気になりました。

  • 対象の列の数を制限しないと、遅くなりそう
  • セルを複数選択した場合には、どうしようか

で、セルに色を付ける方法を変えることで、対応したらどうでしょうか、という提案です。
「条件付き書式」は、セルの書式設定の書式に優先されます。
色を保存しておきたいセルには、セルの書式ではなく、条件付き書式で、以下のような設定をします。
f:id:a-kuma3:20141010213323p:image
数式には「=TRUE」、つまり、常に成立する、を指定して、書式で背景色を指定します。

すると、先に挙げたコードで、複数のセルを選択した場合、こんなような感じになります。
f:id:a-kuma3:20141010213324j:image


追記です。

ただ私が色を付けたいセルというのは、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 の方が良かったかも。

他11件のコメントを見る
id:a-kuma3

どかどかコードを貼り付けてしまったので、分かりにくくなって、すみませんでした。
なんとか希望されてるものに、近いものになって、ホッとしました　:-)

どうでも良いことですが、VBA って、苦手で。
できれば、一生、触らずに済ませたいんですが、そうも行かないというか、便利な場面があることが分かってるだけに、たまにいじります。
今回は、ぼくも、良い勉強をさせていただきました。
加えて、過分なポイントをいただき、ありがとうございました。

2014/10/12 20:45:27
id:egaosaiko


a-kuma3 さんへ


いえ、とても分かりやすいコードの書き方(背景が黒のスペースにコードがまとまって書かれているので)ですよ。
しかもまさに理想通りの動作をしてくれるコードで、とても嬉しいです!


a-kuma3さんがVBA苦手って、すごく謙虚ですね。
能ある鷹は爪隠す、と言いますかなんか凄すぎて単純に尊敬してしまいます。


もし、また自分を見かけることがありましたら今後ともよろしくお願いいたします。

2014/10/12 21:40:30
id:kazukichi_0914 No.2

回答回数126ベストアンサー獲得回数8

なんかもっとこんな難しいことしなくても条件付きセルにして、値があったら色をつけるとかの設定がありますよ。
「条件付きセル」ですね。
osはwindowsってことでいいですか？

他3件のコメントを見る
id:kazukichi_0914

ここがいい例だと思います。　http://www.becoolusers.com/excel/conditional-formatting-fx.html

2014/10/12 20:43:03
id:egaosaiko

かずきち。 さんへ

参考URLを教えていただきまして、ありがとうございます。

条件付き書式は使う場面も多いと思いますので、
知ってると何かと役に立ちそうですね。

私の場合ずっと使わないと、条件付き書式の書き方って意外と忘れてしまうので
今後のためにブックマークさせていただきました。

ありがとうございます。

2014/10/12 21:50:03

コメント（0件)

コメントはまだありません

この質問への反応（ブックマークコメント）

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

回答リクエストを送信したユーザーはいません
ユーザー登録をして使いはじめる!無料
すでに登録されている方はこちらからログイン
この質問に含まれるキーワード
知りたいことを検索してみよう
▲ページトップへ