エクセルマクロFor Eachの処理が長い

質問

エクセル2013です。
皆さんに教えていただいて以下のマクロが完成しました。

サンプルデータ
３０行、7列ではあっという間に処理ができたのですが
本番環境
800行、50列ですと
処理時間が長く
青丸がくるくる回っていて、2分後にくらいで終わります。
もう少し早く処理する方法はありますでしょうか？
Findで検索して、一括削除？
（それはマクロでできるのでしょうか？）
よろしくお願いします。

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

回答No.2

mar00 · ベストアンサー

基準色になるのはA8、B8iの順にしています。

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

High_Score

個別削除から一括削除への変更は効果ありますが、クリアはどうでしょうか？
Unionを使い、クリア対象セルを全部溜め込んでおき、一括クリアします。

Dim myRange As Range
set myRange=cells(1,1) '何でもいいので、使わないセルを1個指定しておく

For eachの中で
対象セル.clearContents
の代わりに
myRange=Union(myRange, 対象セル)

For each終了後、
myRange.clearContents

お礼

ありがとうございます。
試してみます。

回答No.1

tom04

こんばんは！

＞800行、50列ですと処理時間が長く

4000セルのループですか！若干時間を要するかもしれませんね。
Excel2007以降ですと色フィルタが使えますので、それを利用した一例です。

Sub Sample1()
Dim j As Long, k As Long, lastRow As Long, lastCol As Long
Dim myColor1 As Long, myColor2 As Long, myArry
myColor1 = Range("A8").Interior.Color
myColor2 = Range("B8").Interior.Color
myArry = Array(myColor1, myColor2)
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
lastCol = Cells(8, Columns.Count).End(xlToLeft).Column
If lastRow > 9 And lastCol > 16 Then
Application.ScreenUpdating = False
On Error Resume Next '←念のため
For k = 0 To 1
For j = 17 To lastCol
Rows(9).AutoFilter field:=j, Criteria1:=myArry(k), Operator:=xlFilterCellColor
If Cells(Rows.Count, j).End(xlUp).Row > 9 Then
Range(Cells(10, j), Cells(lastRow, j)).SpecialCells(xlCellTypeVisible).ClearContents
End If
AutoFilterMode = False
Next j
Next k
Application.ScreenUpdating = True
End If
End Sub

少しは時間短縮が可能になると思います。m(_ _)m

お礼

ありがとうございます。
今の私にはレベルが高いようです。