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

質問

エクセル2013です。
セルの値が0又は空白の場合でそのセルが色塗りされていたら色を消す
というマクロをを作成しました。
ただ700行55列では処理が遅いです。

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

対象範囲から対象セルを全部見つけて一括処理すれば早いのではと
以下のマクロを作成してみましたが
Set 対象範囲 = Cells.Find(What:=0 Or "", LookIn:=xlValues, LookAt:=xlWhole)
で構文ERRです。
どこを直せばいいのでしょうか？
よろしくお願いします。

Sub 色消2()
'2014/8/4
'失敗
Dim 対象範囲
Dim 最終行
Dim 最終列

最終列 = Cells(8, Columns.Count).End(xlToLeft).Column '8行目の最終列を取得
最終行 = Cells(Rows.Count, 1).End(xlUp).Row 'A列の最終行を取得
対象範囲 = Range(Cells(10, 17), Cells(最終行, 最終列))

Set 対象範囲 = Cells.Find(What:=0 Or "", LookIn:=xlValues, LookAt:=xlWhole)
If Not 対象範囲 Is Nothing Then
対象範囲.Interior.ColorIndex = 0
End If
End Sub

回答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秒かからなくうまくいったので
応用しようとしていますがうまくできません。

回答No.3

cj_mover

＃１、２、ｃｊです。
すみません。編集ミスがありましたので取り急ぎ訂正、自己レスです。
ReplaceFormat版の方、
誤）
　　' ' 自動計算停止（数式の参照先を含まないなら不要）
　　.Calculation = xlCalculationAutomatic
　　' ' 描画抑止
　　.ScreenUpdating = True
正）
　　' ' 自動計算停止（数式の参照先を含まないなら不要）
　　.Calculation = xlCalculationManual
　　' ' 描画抑止
　　.ScreenUpdating = False

ついでに全体で、"描画"は"描画更新"の方が意味が通りますね。

以上訂正します。失礼しました。
今から出掛けますので、もし再レスが必要な場合は明日以降になるかも知れません。一応。

お礼

ご丁寧にありがとうございます。
気を使わせて大変申し訳なく思います。
いろいろありがとうございました。

回答No.2

cj_mover

＃１、ｃｊです。＃１お礼欄・補足欄、拝見しました。

まずはお礼欄について。
.ReplaceFormatプロパティを設定した上で、
.Replaceメソッドで処理したい、ということです？
確かにこの方法なら速いですけれど、
処理できるのは定数値のみ、数式の戻り値は無視されますが、
それでいいのでしょうか？
とりあえず、プロット程度ですが、、、。

Sub Re870387e()
　Const 先頭行 As Long = 10
　Const 先頭列 As Long = 17　'　Ｑ列相当
　Dim 行数 As Long, 列数 As Long

　With Application
　　' ' イベント発行停止（Chane,SelectionChange,Calculate未使用なら不要）
　　.EnableEvents = False
　　' ' イベント発行停止のままエラー終了しないようにトラップ（念の為）
　　On Error GoTo Out_

　　' ' Ａ列を基準に対象範囲の行数を取得
　　行数 = Cells(Rows.Count, 1).End(xlUp).Row - 先頭行 + 1
　　' ' ８行目を基準に対象範囲の列数を取得
　　列数 = Cells(8, Columns.Count).End(xlToLeft).Column - 先頭列 + 1
　　' ' 自動計算停止（数式の参照先を含まないなら不要）
　　.Calculation = xlCalculationAutomatic
　　' ' 描画抑止
　　.ScreenUpdating = True

　　.FindFormat.Clear
　　.ReplaceFormat.Clear
　　.ReplaceFormat.Interior.ColorIndex = xlColorIndexNone
　End With

　With Cells(先頭行, 先頭列).Resize(行数, 列数)
　　.Replace What:=0, Replacement:=0, LookAt:=xlWhole, ReplaceFormat:=True
　　.Replace What:="", Replacement:="", LookAt:=xlWhole, ReplaceFormat:=True
　End With
Out_:
　With Application
　　.ReplaceFormat.Clear
　　' ' イベント発行再開
　　.EnableEvents = True
　　' ' 自動計算再開
　　.Calculation = xlCalculationAutomatic
　　' ' 描画再開
　　.ScreenUpdating = True
　End With
　If Err Then MsgBox Err & vbLf & Err.Description
End Sub

続いて補足欄。
処理の遅さが問題だとしたら、Application系の更新抑止を丁寧に書けば、
場合によって多少の改善は望めるとは思います。
700*55程度でしたらコンマ数秒程度でしょうから、遅いと言えるかどうか微妙ですね。
なので、＃１では書式操作を一度に纏める、という意図だけでお応えした訳です。
Excel VBA もVer2007以降は随分様変わりしましたから、
以前なら高速に処理できた手法もキャッシュファイルが邪魔して、
一度に纏めての処理が却って遅い場合なんかもあったりして、、、。
もっと速くということだとhttp://okwave.jp/qa/q4007086.html辺りを
現代版に書き直す方法もあるとは思いますが、まぁあの頃に比べれば。
ＰＣもExcelも随分速くなりましたから、処理速度ネタは最近あまり興味なかったりします。
もっと速くということでしたら、また考えますけれど、、、。
さて前述の通り、.ReplaceFormatでは数式の戻り値を処理に反映できないという意味で、
上記のマクロはご提示のSub 色消()とは仕様が異なる結果になってしまいます。
それでも構わないなら、それでいいですが、
当初の条件で、もう少し速くなるものを書いてみました。
これが最速ではありませんが、最近配列変数について興味をお持ちかと思いましたので、
一応掲げてみます。

Sub Re870387j()
　　Const 先頭行 As Long = 10
　　Const 先頭列 As Long = 17　'　Ｑ列相当

　　Dim 二次元配列B()
　　Dim 二次元配列V()
　　Dim 判別用二次元配列()
　　Dim 単位行数 As Long
　　Dim 行数 As Long
　　Dim 列数 As Long
　　Dim 行 As Long
　　Dim 列 As Long

　　' ' イベント発行停止（Chane,SelectionChange,Calculate未使用なら不要）
　　Application.EnableEvents = False
　　' ' イベント発行停止のままエラー終了しないようにトラップ（念の為）
　　On Error GoTo Out_

　　' ' Ａ列を基準に対象範囲の行数を取得
　　行数 = Cells(Rows.Count, 1).End(xlUp).Row - 先頭行 + 1
　　If 行数 < 1 Then MsgBox 先頭行 & "行以下にデータなし！": Exit Sub
　　' ' ８行目を基準に対象範囲の列数を取得
　　列数 = Cells(8, Columns.Count).End(xlToLeft).Column - 先頭列 + 1
　　If 列数 < 1 Then MsgBox 先頭列 & "列以右にデータなし！": Exit Sub
　　If 行数 * 列数 = 1 Then MsgBox "単セル非対応。手作業でお願い！": Exit Sub

　　' ' 判別用二次元配列のサイズを再定義
　　ReDim 判別用二次元配列(1 To 行数, 1 To 列数)

　　' ' 処理対象範囲をブロック化
　　With Cells(先頭行, 先頭列).Resize(行数, 列数)
　　　　' ' 値・数式を後で元に戻す為の配列変数
　　　　二次元配列B() = .Formula
　　　　' ' 値を確認する為の配列変数
　　　　二次元配列V() = .Value

　　　　For 行 = 1 To 行数
　　　　　　For 列 = 1 To 列数
　　　　　　　　Select Case 二次元配列V(行, 列)　'　値を確認して
　　　　　　　　Case Empty, 0　'　Emptyまたは0ならば
　　　　　　　　　　' ' フラグとしての１を判別用配列変数に格納
　　　　　　　　　　判別用二次元配列(行, 列) = 0
　　　　　　　　End Select
　　　　　　Next 列
　　　　Next 行
　　　　Erase 二次元配列V()　'　使用済みの変数を初期化

　　　　' ' 描画抑止
　　　　Application.ScreenUpdating = False
　　　　' ' 自動計算停止（数式の参照先を含まないなら不要）
　　　　Application.Calculation = xlCalculationManual

　　　　' ' フラグを格納した判別用配列変数をセル範囲に出力
　　　　.Value = 判別用二次元配列
　　　　Erase 判別用二次元配列()　'　使用済みの配列変数を初期化

　　　　' ' 何行ずつ纏めて処理するかを環境に合わせてt設定
　　　　' ' 大き過ぎると処理が遅くなる
　　　　単位行数 = 20　'　本来はプロシージャ上部記述する（Const が相応）

　　　　' ' 単位行数ステップでループ
　　　　For 行 = 1 To 行数 Step 単位行数
　　　　　　' ' 端数の調整
　　　　　　If 行 + 単位行数 > 行数 Then 単位行数 = 行数 - 行 '+ 1
　　　　　　' ' 処理対象がない場合のエラー対策
　　　　　　On Error Resume Next
　　　　　　' ' フラグが立っているセルを纏めて[塗り潰しなし]にする
　　　　　　.Rows(行 & ":" & 行 + 単位行数).SpecialCells(xlCellTypeConstants).Interior.ColorIndex = xlColorIndexNone
　　　　　　On Error GoTo Out_:
　　　　Next 行

　　　　' ' 配列変数をセル範囲に出力して値・数式を元に戻す
　　　　.Formula = 二次元配列B()
　　　　Erase 二次元配列B()　'　使用済みの変数を初期化
　　End With

Out_:
　　With Application
　　　　' ' イベント発行再開
　　　　.EnableEvents = True
　　　　' ' 自動計算再開
　　　　.Calculation = xlCalculationAutomatic
　　　　' ' 描画再開
　　　　.ScreenUpdating = True
　　End With
　　If Err Then MsgBox Err & vbLf & Err.Description
End Sub

お礼

夏季休暇に入ってしまい
自分が制御できるコードで
とりあえずリリースしまＨした。
ありがとうございます。