『条件付書式マクロ 特定の列の色を変えたい』(りの) 下記、M3からAU3行の中で数字1(weekday関数にて表示する)が 存在すれば、そこから同じ列の5行目から10行目まで色をつけるマクロを 作りたいのですが、エラーになってしまいます。 どこがおかしいかわかるかたご指摘いただけないでしょうか。 条件付書式を入れれば簡単なのですが、データ量が多めなので 全シートに設定すると一気にデータが重くファイルが固まってしまうため マクロで色づけしたいと思っています。 また、途中で色をつけずにその下の行の色付けを同時に場合は どうすればよろしいのでしょうか? (例えば5行目から10行目までと15行目から20行目までなど) 恐縮ですがよろしくお願い致します。 Sub 日曜日色づけ() With Range("M3:AU3").FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, Formula1:="1") Range(offset(5, 0), offset(10, 0)).Interior.Color = RGB(255, 204, 103) End With End Sub < 使用 Excel:Excel2013、使用 OS:Windows7 > ---- 条件付き範囲の適用範囲の工夫で解決しそうな気もしますが、それはさておき Sub 日曜日色づけ() Dim r As Range Dim iPattern As Long For Each r In Range("M3:AU3") 'M3:AU3の範囲のセルについて If r.Value = 1 Then '値が1なら iPattern = xlSolid '塗りつぶす設定ON Else '値が1以外なら iPattern = xlNone '塗りつぶす設定OFF End If With r.Offset(2).Resize(6).Interior '3行目の2行下から6行(=5行目から10行目)の範囲について .Pattern = iPattern '塗りつぶす設定を適用 If iPattern <> xlNone Then '塗りつぶす設定がOFFでない場合は .Color = RGB(255, 204, 103) '指定の色にする End If End With Next End Sub (きまぐれおじさん) 2021/12/07(火) 11:04 ---- r.Offset(2).Resize(6) ↓ Intersect(r.EntireColumn, Range("5:10,15:20")) こんな風にすると飛び飛びの行の指定が可能です。 (きまぐれおじさん) 2021/12/07(火) 11:08 ---- Sub 条件付き書式で() With Intersect(Range("M:AU"), Range("5:10,15:20")).FormatConditions '古い条件付き書式を削除 .Delete '新しく条件付き書式を設定 .Add(Type:=xlExpression, Formula1:="=M$3=1").Interior.Color = RGB(255, 204, 103) End With End Sub ついでに条件付き書式でやる方も (きまぐれおじさん) 2021/12/07(火) 11:17 ---- Sub 全シートに条件付き書式() Dim ws As Worksheet For Each ws In Worksheets Select Case ws.Name Case "Sheet1", "Sheet2" '除外するシート名 Case Else With Intersect(ws.Range("M:AU"), ws.Range("5:10,15:20")).FormatConditions '古い条件付き書式を削除 .Delete '新しく条件付き書式を設定 .Add(Type:=xlExpression, Formula1:="=M$3=1").Interior.Color = RGB(255, 204, 103) End With End Select Next End Sub おまけのおまけで全シート(除外シート設定あり)に同じ条件付き書式を設定するコードも (きまぐれおじさん) 2021/12/07(火) 11:35 ---- きまぐれおじさんさん ありがとうございます! ちなみに他の列にもすでに別な色がいろいろ入っておりまして、 ↓下記ですと1以外の部分が白くなってしまいますが そのままの色を生かす(色づけは実施しない)こと可能でしょうか? Else '値が1以外なら iPattern = xlNone '塗りつぶす設定OFF また、飛び飛びのパターンにて実施すると .Pattern = iPattern のところでエラーが発生してしまいます。 併せて恐縮ですがご教示お願い致します。 (りの) 2021/12/07(火) 12:42 ---- Sub 日曜日色づけ() Dim r As Range For Each r In Range("M3:AU3") If r.Value = 1 Then With Intersect(r.EntireColumn, Range("5:10,15:20")).Interior .Pattern = xlSolid '塗りつぶす .Color = RGB(255, 204, 103) '指定の色にする End With End If Next End Sub 背景色の上塗りだけならもう少し簡単になりますが、色塗りを外すのは手動になります。 (きまぐれおじさん) 2021/12/07(火) 12:58 ---- きまぐれおじさんさん ご教示ありがとうございます!解決できました。 (りの) 2021/12/07(火) 13:09