マクロセルの値によってセルの色を消す

質問

• エクセル2013で、セルの値が0または空白の場合で、セルが色塗りされていたら色を消すマクロを作成しました。ただ、700行55列では処理が遅いです。
• 対象範囲から対象セルをすべて見つけて一括処理すれば処理が早くなると考え、以下のマクロを作成しましたが、構文エラーが発生しています。
• どこを修正すればいいのでしょうか？

回答No.1

cj_mover · ベストアンサー

こんにちは。
色々方法はありますが、Findメソッドを使って一括というのは難しいと思います。

とりあえず一例として、Range型変数に、
塗り潰しをキャンセルする処理対象範囲を格納するパターン。
書式操作を一度に纏める、という意味では、最もポピュラーで簡単に書ける方法です。
＃すみませんけれど、Range(Cells(), Cells())書式は私の守備範囲外なので、
＃書き換えています。そちらで適当に書き換えてみてくださいませ。

Sub Re870387a()
　　Const 先頭行 As Long = 10
　　Const 先頭列 As Long = 17
　　Dim 処理対象範囲 As Range
　　Dim 対象セル As Range
　　Dim 行数 As Long
　　Dim 列数 As Long

　　' ' ８行目を基準に対象範囲の列数を取得
　　列数 = Cells(8, Columns.Count).End(xlToLeft).Column - 先頭列 + 1
　　' ' Ａ列を基準に対象範囲の行数を取得
　　行数 = Cells(Rows.Count, 1).End(xlUp).Row - 先頭行 + 1
　　' ' 対象範囲を総当たりループ
　　For Each 対象セル In Cells(先頭行, 先頭列).Resize(行数, 列数)
　　　　If 対象セル.Value = 0 Or 対象セル = "" Then
　　　　　　If 処理対象範囲 Is Nothing Then　'　処理対象範囲が未設定なら
　　　　　　　　Set 処理対象範囲 = 対象セル　'　処理対象範囲に設定
　　　　　　Else　'　設定済なら　'　処理対象範囲に追加設定
　　　　　　　　Set 処理対象範囲 = Application.Union(処理対象範囲, 対象セル)
　　　　　　End If
　　　　End If
　　Next
　　' ' 処理対象範囲が未設定でなければ、処理対象範囲の塗りつぶしを一度に纏めてキャンセル
　　If Not 処理対象範囲 Is Nothing Then 処理対象範囲.Interior.Pattern = xlNone
End Sub

お礼

>Range(Cells(), Cells())書式は私の守備範囲外
いえいえ、とんでもありません。
教えて頂いたコードでしたらこれは不要でした。
何でもかんでも
Range(Cells(), Cells())
にすればいいのではない事がわかりました。

教えていただいたコードですが
思ったとうりに動作いたしました。
自作で成功している
Sub 色消()
'成功

Dim 最終行
Dim 最終列
Dim 対象セル As Range

最終列 = Cells(8, Columns.Count).End(xlToLeft).Column '8行目の最終列を取得
最終行 = Cells(Rows.Count, 1).End(xlUp).Row 'A列の最終行を取得
For Each 対象セル In Range(Cells(10, 17), Cells(最終行, 最終列))
If 対象セル.Value = 0 Or 対象セル = "" Then
対象セル.Interior.ColorIndex = 0
End If
Next 対象セル
End Sub

と処理速度がかわりませんでした。
どうもありがとうございました。

補足

http://okwave.jp/qa/q8695934.html
にて

Sub 出荷済削除()

Dim 対象セル As Range
Dim 対象色 As Long
Dim 対象色2 As Long
Dim 最終行
Dim 最終列

最終列 = Cells(8, Columns.Count).End(xlToLeft).Column '8行目の最終列を取得
最終行 = Cells(Rows.Count, 1).End(xlUp).Row 'A列の最終行を取得

Application.ScreenUpdating = False '画面切替停止

対象色 = Range("B8").Interior.Color 'セルB8の色を基準色とする
対象色2 = Range("A8").Interior.Color 'セルB8の色を基準色とする

For Each 対象セル In Range(Cells(10, 17), Cells(最終行, 最終列))
If 対象セル.Interior.Color = 対象色 Or 対象セル.Interior.Color = 対象色2 Then 対象セル.ClearContents
Next 対象セル

Application.ScreenUpdating = True '画面切替停止解除

End Sub

を

Sub 出荷済削除()

Dim 対象色 As Long
Dim 最終行 As Long, 最終列 As Long
Dim i As Integer

最終列 = Cells(8, Columns.Count).End(xlToLeft).Column '8行目の最終列を取得
最終行 = Cells(Rows.Count, 1).End(xlUp).Row 'A列の最終行を取得

For i = 1 To 2
対象色 = Cells(8, i).Interior.Color
Application.FindFormat.Clear
Application.FindFormat.Interior.Color = 対象色
Range(Cells(10, 17), Cells(最終行, 最終列)).Replace "", "", xlWhole, , , , True
Next i

End Sub

にするように教えていただき1秒かからなくうまくいったので
応用しようとしていますがうまくできません。