For Nextマクロの高速化についてご教示ください。

Question

エクセル2000です。

以下は、ワークシートのA列の２行目以降に赤（Interior.ColorIndex = 3 ）のセルがあればその行を非表示に、１行目のA列以降に赤いセルがあればその列を非表示にする単純なマクロです。通常はストレスなく動いてくれるのですが、あるBOOKにこのマクロを設定したら、わずか200行程度の処理に1分以上かかってしまいました。
そのBOOKは1.4MBあるのでそのせいとも思えるのですが、それにしても時間がかかりすぎるような気もします。
高速化する方法がありましたらご教示くださいませ。
(o。_。)oペコッ

Private Sub 行列非表示()

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    With ActiveSheet
    
    x = .Cells(1, 1).SpecialCells(xlLastCell).Row
    y = .Cells(1, 1).SpecialCells(xlLastCell).Column
    
        For i = 2 To x
            If .Cells(i, "A").Interior.ColorIndex = 3 Then
                .Rows(i).Hidden = True
            End If
            Application.StatusBar = i
        Next i
        For n = 1 To y
            If .Cells(1, n).Interior.ColorIndex = 3 Then
                .Columns(n).Hidden = True
            End If
            Application.StatusBar = n
        Next n
    End With
    Application.StatusBar = ""
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Exit Sub
End Sub

cj_mover · Accepted Answer

こんにちは
せっかくだからもう少し、、、なんて、また考え出したらキリがなくて、、、
結局殆ど元通り、完全ではありませんがUPします。
特殊なものですので、珍品コレクションにでも加えて下さい。


条件：　シートが標準の表示状態であること。
　　　　セルの保護、セルの結合、スクロールエリア設定、など非対応。

〔　標準モジュール　〕　Excel2000、2002 で動作テスト済


Sub RC_非表示_ACU()

Dim blnArr() As Boolean
Dim lngC As Long
Dim lngR As Long
Dim c As Long
Dim d As Long
Dim lngUB As Long
Dim strB As String
Dim strArr() As String
Dim rngT As Range
Dim rngB As Range

　　With Application
　　　　.Calculation = xlCalculationManual
　　　　.ScreenUpdating = False
　　　　.EnableEvents = False
　　End With

　　With Cells.SpecialCells(xlLastCell)
　　　　lngC = .Column
　　　　lngR = .Row
　　End With

' ' ■　列　■

If lngC > 1 Then

' '【c１】セル範囲を走査し、判定をブール型の配列に

　　ReDim blnArr(lngC + 1) As Boolean
　　Set rngT = Cells(2).Resize(ColumnSize:=lngC - 1)
　　c = 1

　　For Each rngB In rngT
　　　　c = c + 1
　　　　If rngB.Interior.Color = vbRed Then blnArr(c) = True
　　Next rngB

　　Set rngT = Nothing

' '【c２】ブール型配列から参照文字列を範囲毎に","区切りで列挙

　　For c = 2 To lngC
　　　　If blnArr(c) Then
　　　　　　If Not blnArr(c - 1) Then
　　　　　　　　strB = strB & "," _
　　　　　　　　& Chr$(64 + (c - 1) \ 26) _
　　　　　　　　& Chr$(65 + (c - 1) Mod 26) & "1"
　　　　　　ElseIf Not blnArr(c + 1) Then
　　　　　　　　strB = strB & ":" _
　　　　　　　　& Chr$(64 + (c - 1) \ 26) _
　　　　　　　　& Chr$(65 + (c - 1) Mod 26) & "1"
　　　　　　End If
　　　　End If
　　Next c

　　Erase blnArr
　　strB = Replace(Expression:=strB, Find:="@", Replace:="")
　　strB = Mid$(String:=strB, Start:=2)

' '【c３】255文字以下、最大位置にある区切り文字を";"に置換後、配列化

　　Do
　　　　d = InStrRev(StringCheck:=strB, StringMatch:=",", Start:=d + 256)
　　　　If d Then Mid(strB, d, 1) = ";"
　　Loop While d
'　　Debug.Print "#"; Left(strB, 30); "~"; vbLf; "~" _
　　; Mid(strB, 241, 30); "~"; vbLf; "~"; Right(strB, 30); "#" ' 確認用

　　strArr = Split(Expression:=strB, Delimiter:=";")
　　strB = ""

' '【c４】配列毎に参照文字列でRangeを取得し、非表示に

　　lngUB = UBound(strArr)

　　For c = 0 To lngUB
　　　　Range(strArr(c)).EntireColumn.Hidden = True
　　Next c

　　Erase strArr

End If

' ' ■　行　■

If lngR > 1 Then

' '【r１】

　　ReDim blnArr(lngR + 1) As Boolean
　　Set rngT = Cells(2, 1).Resize(rowSize:=lngR - 1)
　　c = 1

　　For Each rngB In rngT
　　　　c = c + 1
　　　　If rngB.Interior.Color = vbRed Then blnArr(c) = True
　　Next rngB

　　Set rngT = Nothing

' '【r２】

　　For c = 2 To lngR
　　　　If blnArr(c) Then
　　　　　　If Not blnArr(c - 1) Then
　　　　　　　　strB = strB & ",A" & c
　　　　　　ElseIf Not blnArr(c + 1) Then
　　　　　　　　strB = strB & ":A" & c
　　　　　　End If
　　　　End If
　　Next c

　　　　Erase blnArr
　　strB = Mid$(String:=strB, Start:=2)

' '【r３】

　　Do
　　　　d = InStrRev(StringCheck:=strB, StringMatch:=",", Start:=d + 256)
　　　　If d Then Mid(strB, d, 1) = ";"
　　Loop While d

　　strArr = Split(Expression:=strB, Delimiter:=";")
　　strB = ""

' '【r４】

　　lngUB = UBound(strArr)
' '　　　　　　　　　　　　　　　　　　　◆↓
　　For c = 1 To (lngUB + 1) \ 30
　　　　Union(Range(strArr(d)), Range(strArr(d + 1)), Range(strArr(d + 2)) _
　　　　, Range(strArr(d + 3)), Range(strArr(d + 4)), Range(strArr(d + 5)) _
　　　　, Range(strArr(d + 6)), Range(strArr(d + 7)), Range(strArr(d + 8)) _
　　　　, Range(strArr(d + 9)), Range(strArr(d + 10)), Range(strArr(d + 11)) _
　　　　, Range(strArr(d + 12)), Range(strArr(d + 13)), Range(strArr(d + 14)) _
　　　　, Range(strArr(d + 15)), Range(strArr(d + 16)), Range(strArr(d + 17)) _
　　　　, Range(strArr(d + 18)), Range(strArr(d + 19)), Range(strArr(d + 20)) _
　　　　, Range(strArr(d + 21)), Range(strArr(d + 22)), Range(strArr(d + 23)) _
　　　　, Range(strArr(d + 24)), Range(strArr(d + 25)), Range(strArr(d + 26)) _
　　　　, Range(strArr(d + 27)), Range(strArr(d + 28)), Range(strArr(d + 29))) _
　　　　.EntireRow.Hidden = True
　　　　d = c * 30
　　Next c

　　If (lngUB - d + 1) \ 15 Then
　　　　Union(Range(strArr(d)), Range(strArr(d + 1)), Range(strArr(d + 2)) _
　　　　, Range(strArr(d + 3)), Range(strArr(d + 4)), Range(strArr(d + 5)) _
　　　　, Range(strArr(d + 6)), Range(strArr(d + 7)), Range(strArr(d + 8)) _
　　　　, Range(strArr(d + 9)), Range(strArr(d + 10)), Range(strArr(d + 11)) _
　　　　, Range(strArr(d + 12)), Range(strArr(d + 13)), Range(strArr(d + 14))) _
　　　　.EntireRow.Hidden = True
　　　　d = d + 15
　　End If
' '　　　　　　　　　　　　　　　　　　　◆↑
　　For c = d To lngUB
　　　　　　Range(strArr(c)).EntireRow.Hidden = True
　　Next c

　　Erase strArr

End If
' ' ■　　　■
　　With Application
　　　　.Calculation = xlCalculationAutomatic
　　　　.ScreenUpdating = True
　　　　.EnableEvents = True
　　End With

End Sub


　　おことわりしておきますが、普通はこんなことする人いないです。
　　私の場合は仕事上の必要から高速処理の為なら何でもする派ですが、
　　シンプルで済ませられるものは、シンプルに書く派でもあります。（？）

　　高速化のポイントとしては、
　　「オブジェクトに触る回数を減らすこと」「ループ中に余計なことをしない」

　　,Address プロパティを取得するより、書いた方が実は速かったりするのです。
　　【１】から【３】の部分は【１】のFor Eachの中に纏めることもできるのですが、
　　分岐が複雑になり、かえって遅くなりますし、記述も長くなります。
　　【１】と【２】のループ中の条件分岐は、書き方が山ほどありますが。
　　平凡に見えるこのやり方が、このコードの一番のポイントです。
　　「判定がFalseなら、何もしないで即、Next」ということだけですけれど。

　　【３】に出てくる Mid は、Mid()関数ではなく、Mid ステートメントです。

　　◆↓　から　◆↑　の部分は無くもそのまま使えます。（長いけど(^^;）
　　非表示にする範囲各々の行や列が、「単独」か「連続」か、
　　その割合によっては無い方が速い場合もあります。
　　（↑テスト用の極端なシート等では特に）
　　バランスよくする為だけにある記述です。


　　この他に、作業セルに判定を書いて（非表示の場合だけTRUEなどにして）
　　.SpecialCells(Type:=xlCellTypeConstants, Value:=xlLogical).EntireColumn
　　で非表示にする方法も条件によってはより速い場合もあります。
　　やはり配列を使って、判定を一括でシートにはき出して消す方法ですが、
　　一般的な実務で考えたら、そちらの方が良いかも知れませんね。

　　長々と失礼しました。それでは、また。

cj_mover · Answer

こんにちは
レスをどうも

セルひとつずつのアドレスを採る方法だと、
ご指摘のような逆転もあるのは存じておりました。
最善最速のコードでは、連続した矩形範囲ごとのアドレスを合成するロジック
を用いていまして（これを特殊と呼びました）、
こちらだと逆転はありませんでした（笑）
ただし、常識的な実用面から見ると単セル方式でも 
十分だと思います。
或いは、配列を用いない方法でも、丁寧に書けば、
よくある普通のシートなら遜色ないタイムにはなります。

敢えて配列で、、、
という話でしたので、余計な話をしまして、すみません。
「高速化」は、やり出すとキリがないですから、
結局、メンテナンスを含めた実用面から、
今、必要なものを導くしかないと思います。
今回は研究ネタ、ということでご勘弁を。

cj_mover · Answer

重ねて、すみません。

不要な訂正でした。
勇み足で、不要な投稿でした。
そのままが良かったのですね。
大変失礼致しましたm(＿)m

cj_mover · Answer

すみません。訂正です。

誤り）
＞　i = 1
＞For Each Rg In rngO
＞　i = i + 1
正しくは）
For Each Rg In rngO

以上、訂正をお願いします。
別バージョンの名残って奴です。

失礼しました。

cj_mover · Answer

こんにちは蛇足になりますが、先日の補足がてら、、、 Range など、オブジェクトの.Itemをループさせる場合基本として、　For ～ Next よりも　For Each ～ Next さらに範囲全体をRange型変数に格納してから　Set RR = Cells(2).Resize(, Y) 　For Each R In RR 　　i = i + 1 　　処理　Next R とした方が速くなります。 ↑これだけで、かなり違います。　値の入った配列変数をループさせる場合は　UB = Ubound(arrX) 　For I = 0 To UB 　arrX(I) 　Next I の形をお奨めします。　＞If a > 30 Or i = X Then 　何故、30なのか？ 30なら間違いはないのですが、念の為根拠を示します。 ※参照文字列に指定できるAreasの数に対する制限ではありません。※ ↑この点を誤認される方がいないように補足しますと、、、参照文字列の上限が255文字、だから、それを超えないように工夫が必要、ということです。 ",A1" ～ ",Z9" 3文字 → 256 \ 3 = 85 ",AA1" ～ ",IV9"、",A10" ～ ",Z99" 4文字 → 256 \ 4 = 64 ",AA10" ～ ",IV99"、",A100" ～ ",Z999" 5文字 → 256 \ 5 = 51 ",AA100" ～ ",IV999"、",A1000" ～ ",Z9999" 6文字 → 256 \ 6 = 42 ",AA1000" ～ ",IV9999"、",A10000" ～ ",Z65536" 7文字 → 256 \ 7 = 36 ",AA10000" ～ ",IV65536" 8文字 → 256 \ 8 = 32 汎用性を考えるなら、（単一セルの場合）32までAreaを指定できます。配列のインデクスが 1 ではなく 0 から始まるからー1 して 31。 >= ではなくて > で表すから If a > 30…。仮に、10000行未満の範囲と限定できるなら、 If a > 34…。 10000行未満、26列以下なら、 If a > 40…となります。また、RangeオブジェクトのAreasのアイテム数制限は原則的にはありません。　文字列の配列を作る時は strB = strB & " " & "値"...(これをLoop) strB = Ltrim(strB) strArr = Split(strB) とか strB = strB & "," & "値"...(これをLoop) strB = Mid(strB, 2) strArr = Split(strB, ",") とかの形の方が、コーディング、デバグ、動作、ともに速いと思います。 Redim 方式が勝る場合もある筈ですが、この場合はやるならSplitをお奨めします。ただ、この点は好みや考えの分かれる所かも知れません。暇な時にでも試してみてください。以上を踏まえて書いてみたのですが、参考程度に、、、（先日触れた特殊なものとは違います。これで完全という訳ではありませんが。）条件：　シートの表示は標準　アウトライン、オートフィルター、セルの保護、セルの結合、　シートのスクロールエリア設定、など、非対応です。〔　標準モジュール　〕　Excel2000、2002、2003 で動作テスト済 Option Explicit Sub RC_非表示_OC() Dim Y As Long, X As Long Dim rngO As Range, Rg As Range Dim i As Long, strB As String Dim lngL As Long, lngD As Long, lngU As Long Dim strAr() As String 　Application.Calculation = xlCalculationManual 　Application.ScreenUpdating = False 　Application.EnableEvents = False 　With Cells.SpecialCells(xlLastCell) 　　Y = .Column 　　X = .Row 　End With 'ーーーーーーーーーーー列ーーーーーーーーーーー '【１】対象セルの参照文字列を列挙　Set rngO = Cells(2).Resize(1, Y - 1) 　strB = "" 　i = 1 For Each Rg In rngO 　i = i + 1 　If Rg.Interior.ColorIndex = 3 Then strB = strB & "," & Rg.Address(RowAbsolute:=False, ColumnAbsolute:=False) Next Rg 　strB = Mid$(strB, 2) '【２】255文字以下で区切って参照文字列を配列に　lngL = Len(strB) 　lngD = 1 Do 　lngD = InStrRev(strB, ",", lngD + 255) 　If lngD > 0 Then Mid(strB, lngD, 1) = ";" Loop While lngD > 0 And lngD <= lngL 　strAr = Split(strB, ";") '【３】参照文字列の配列毎に　（列を）隠す　lngU = UBound(strAr) For i = 0 To lngU 　Range(strAr(i)).EntireColumn.Hidden = True Next i '↓　Unionでひとつの範囲に纏めてから　隠す（遅い） 'Set rngO = Range(strAr(0)) 'For i = 0 To lngU 'Set rngO = Union(Range(strAr(i)), rngO).EntireColumn 'Next i 'rngO.Hidden = True 'ーーーーーーーーーーー行ーーーーーーーーーーー　Set rngO = Cells(2, 1).Resize(X - 1) 　strB = "" 　i = 1 For Each Rg In rngO.Cells 　i = i + 1 　If Rg.Interior.ColorIndex = 3 Then strB = strB & ",A" & i Next Rg 　strB = Mid$(strB, 2) 　lngL = Len(strB) 　lngD = 1 Do 　lngD = InStrRev(strB, ",", lngD + 255) 　If lngD > 0 Then Mid(strB, lngD, 1) = ";" Loop While lngD > 0 And lngD <= lngL 　strAr = Split(strB, ";") 　lngU = UBound(strAr) For i = 0 To lngU 　Range(strAr(i)).EntireRow.Hidden = True Next i '↓　Unionでひとつの範囲に纏めてから　隠す（遅い） 'Set rngO = Range(strAr(0)) 'For i = 0 To lngU 'Set rngO = Union(Range(strAr(i)), rngO).EntireRow 'Next i 'rngO.Hidden = True 'ーーーーーーーーーーーーーーーーーーーーーーー　Set rngO = Nothing 　Erase strAr 　Application.Calculation = xlCalculationAutomatic 　Application.ScreenUpdating = True 　Application.EnableEvents = True End Sub

Wendy02 · Answer

こんにちは。

>配列が空でない判定に
>If Join(ArR(), ",") <> "" Then
>としてみましたがこれであってますでしょうか？

今回の場合は、それで良いと思います。

通常、配列変数が成立しているか、いくつか方法があるようですが、通常は、Dummy を使って、Dummy の変数の内容を判定します。

Sub Test()
Dim arX() As String
Dim Dummy As Variant
　On Error Resume Next　'<---- このエラートラップは、以下で
　 Dummy = Empty
　 Dummy = UBound(arX)
　On Error GoTo 0　'<---- 必ず締める
　If Not IsEmpty(Dummy) Then
　 '----------
　End If
End Sub

--------------
Dim arX() As Variant
ReDim arX(0)
arX(0) = Null　'null 文字など、関係のない値を入れる

として、判定を取るという方法もあります。
数値型変数では、-1　を入れる方法などもあります。
============
なお、#9の補足側のコードで、

　　Application.Calculation = xlCalculationAutomatic
　　Application.ScreenUpdating = True
　　Application.EnableEvents = True
　　Exit Sub
line:
　　MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure 行列非表示 of Module1 """
End Sub

としたらどうでしょうか。そのままだと、MsgBox のところを通ってしまいます。
もしくは、Exit Sub の代わりに、line: の下のところは、

If Err.Number >0 Then
　MsgBox "Error ....."
End If

などとします。お好きな方をどうぞ。

Wendy02 · Answer

こんにちは。

>1行目の列方向にしか赤いセルがないと（A列２行目以降に赤いセルが存在しない場合）非表示にならない。

なるほどね、でも、今回も、惜しいですね。(こういう言い方は、ヒンシュクものかも（^^;）

>On Error GoTo line

これを入れているからですが、それは、エラー処理の問題ですね。
今回の件とは別次元の内容ですが、実務的には、エラートラップは、思ったよりも難しいです。通常、エラー処理は、避けようのない場合のみ入れます。まず、避けられるものかどうかを、検討しないといけませんね。

簡単なようですが、ここらが、VBAでは、一番、上級レベルの扱いを受けるようです。

今回は、私は、避けられるかどうかは、あまり検討していませんが、

一例としては、

>On Error GoTo line

On Error Resume Next　
に換えます。

そして、

On Error GoTo 0　'エラートラップを終わらせ、

If Not ur Is Nothing Then
　ur.EntireRow.Hidden = True
End If
If Not uc Is Nothing Then
　uc.EntireColumn.Hidden = True
End If

となります。

エラーの原因は、配列が空で、エラーが発生して、line:側にJump してしまいます。

なお、エラートラップで、エラーハンドラーを使うときは、以下のように、Err.Number と Err.Description を使うと良いようです。

On Error GoTo ErrHandler
　　|
　　|
ErrHandler:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure 行列非表示 of Module1"

これは丁寧な書き方で、プロジェクトをロックしても、ユーザー側に、どこのプロシージャで起きているかを知らせる目的があるからです。普通は、Err.Number &": " & Err.Description だけでもよいです。

cj_mover · Answer

こんにちは

Application.EnableEvents = False
は、あった方が良いですね。
紛れが無くなりDebugもラクになると思います。
.SpecialCells メソッド
.CurrentRegion メソッド
.CurrentArray メソッド
などRangeオブジェクトを取得する記述で、
.Select　や　.Goto　などを目的にしない場合でも、
Worksheet_SelectionChange　イベントが発生するようです。
気が付かない所で、そちらの処理に時間を取られることもあります。
場合によっては「遅さの解決」になります。
試しに、
●Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ブレークポイントを設定して実行すると、わかると思います。

Range メソッド
の引数（文字列）は255バイトが上限です。（Excel2007以降は知りませんが）
　参照文字列の中の ","　カンマは参照演算子です。
指定できる引数の数は、ひとつ、ということになります。
255文字以下なら、いくつでも指定できます。
Range("A1,B1")
と
Union(Range("A1"), Range("B1"))
では、
.Areas.Countが違います。（念の為）

Rangeオブジェクトの.Areasの数に上限があるみたいですね。
ループしながらUnionで整えても、
.Areas.Count.Item が、87を超えると範囲が追加されませんでした。
このことは私もよくわかりません。

「高速化」ということなので、書いたのはあるのですが、どうでしょう。
ご要望があればUPしますが、わりと特殊な方法ですし、
完全というのでもないので躊躇います。

とりあえず、
役に立ちそうな話だけ書きました。

Wendy02 · Answer

こんにちは。

こういうようになるのでは？

For i = 2 To x
If .Cells(i, 1).Interior.ColorIndex = 3 Then
　　ReDim Preserve ArI(a)
　　ArI(a) = .Cells(i, 1).Address(0, 0)
　　a = a + 1
　　'ここではありません。
End If
If a > 20 Or i = x Then
　　ReDim Preserve ArR(k)
　　ArR(k) = Join(ArI(), ",")
　　k = k + 1
　　Erase ArI()
　　a = 0
End If
Next i

If .Cells(i, 1).Interior.ColorIndex = 3 Then
の構文と
If a > 20 Or i = x Then
の構文は、前者に対して、従属した構文ではないと思います。

Wendy02 · Answer

こんばんは。

>どこがまずいのでしょうか？
>For Each u In ArC()　が、「実行時エラー92 Forループが初期化されていません」となってしまいました

惜しいですね!ちょっとのミスです。

For i = 2 To x
If .Cells(i, 1).Interior.ColorIndex = 3 Then
ReDim Preserve ArI(a)
ArI(a) = .Cells(i, 1).Address(0, 0)
a = a + 1

If a > 20 Or i = x Then　'←これは、上のIf ～ End If 構文とは別のものですから、ネスト出来ません。
ReDim Preserve ArR(k)
ArR(k) = Join(ArI(), ",")
k = k + 1
Erase ArI()
a = 0
End If
End If
Next i

>１．行が途中（198行以降）は赤でも非表示になりません。
>２．列のところで

1.2. は直るのですが、後、「最適化原則」(MSDNを調べたら日本語がなくなりました）からすると、片方が終わったら次ではなく、全部、まとめて一気に非表示したほうがよいです。

For Nextマクロの高速化についてご教示ください。

こんにちは

こんにちは

重ねて、すみません。

すみません。

こんにちは

こんにちは。

こんにちは。

この回答への補足

こんにちは

こんにちは。

この回答への補足

こんばんは。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

　こんにちは