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

質問

エクセル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

回答No.15

cj_mover · ベストアンサー

こんにちは
せっかくだからもう少し、、、なんて、また考え出したらキリがなくて、、、
結局殆ど元通り、完全ではありませんが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
　　で非表示にする方法も条件によってはより速い場合もあります。
　　やはり配列を使って、判定を一括でシートにはき出して消す方法ですが、
　　一般的な実務で考えたら、そちらの方が良いかも知れませんね。

　　長々と失礼しました。それでは、また。

お礼

有難うございます。
さっそく実験しました。
2行目から65536行までを塗りつぶしたものではなんと1.03125秒！
驚異的な速さですね。
2行目から65536行までの偶数行だけを塗りつぶしたものでも26.875秒でした。

これからじっくり勉強させていただきます。
お世話様でした。
有難うございました。

回答No.4

end-u

>残念ながら時間はほとんどかわりませんでした。
そうですか。では、あとコードで制御可能なのは
Application.EnableEvents の制御くらいしか思いつきません。お力になれずすみませんm(_ _)m

あとは、コードに問題があるのではなく、
その『200行程度の処理に1分以上』かかるBookの仕様に問題があるのではないか、
探ってみられると良いと思います。

新規Bookに問題のシートのセル範囲をコピーして試してみるとか、
シェイプやオブジェクトの数を調べてみるとか、
条件付き書式などの設定を調べてみるとか。

作業用Bookで、各設定を１つずつデフォルトに戻していく度に、
Private Sub 行列非表示() を実行して比較してみると、何が原因なのか解るのではないかと思います。
もしわかったら教えてくださいね。

お礼

とりあえず、1分以上かかったシートを別BOOKにコピーしてためしたところ瞬時に終わりました。
やはり、BOOKのサイズが大きいせいだと判断し、かたっぱしからシートをクリアしてみましたがほとんどかわりません。
ついには当該シートを含め、すべてのデータをクリアしましたがそれでも変わらないのです。
これはBOOKが壊れているのでしょうか？

補足

今度は、各シートを片っ端から削除してみました。
そしたらある特定のシートを削除すると、飛躍的に早くなることがわかりました。しかしそのシートには現在、なんのデータも入っていないし条件付書式やオブジェクトも配置していません。

(￣～￣;)う～ん　　何なんだ、これは・・・・。

回答No.3

Wendy02

こんにちは。

>そのままやってみたところ、「実行時エラー1004 アプリケーション定義またはオブジェク>ト定義のエラーです」となってしまいます。
>.Range(Join(ArI(), ",")).EntireRow.Hidden = True　がひっかかるようです。どこがわるいのでしょうか？

それは、確か、引数の個数の問題だと思いますね。
調べても出てこないけれど、そんなに多くないですね。たぶん、旧VB系の引数のパラメータ配列ですと、30個ぐらいだったような気がします。

.Range(Join(ArI(), ",")).Select

もし、そうなら、これでも、エラーが発生するはずです。
そうしたら、文字列を適当な個数が来たら、そこで切って、それを、最初、文字列に置き換えていけばよいかもしれません。

If a > 20 Or i = x Then
　　　 ReDim Preserve ArR(k)
　　　 ArR(k) = Join(ArI(), ",")
　　　 k = k + 1
　　　 Erase ArI()
　　　 a = 0
End If

ArR()は、20個とか30個とか区切った単位を格納する文字列
ur は、Union Range の変数

For Each v In ArR()
　　　　　If ur Is Nothing Then
　　　　　　Set ur = .Range(v)
　　　　　Else
　　　　　 Set ur = Union(.Range(v), ur)
　　　　　End If
Next v

この考え方は、要するに、

VBAの基本原則で、VBAの中では、セルに頻繁にアクセスしないこと。
というものがあります。一旦、配列や文字列で取得してから、一気に、セル(行・列含む）を取得すればよいわけです。

お礼

さっそくありがとうございます。
.Range(Join(ArI(), ",")).Select もエラーになります。
それで以下のようにしてみたのですが、
１．行が途中（198行以降）は赤でも非表示になりません。
２．列のところで
For Each u In ArC()　が、「実行時エラー92 Forループが初期化されていません」となってしまいました。
ご教示賜われば幸いです。

コードは補足欄に書きます。

補足

１．行が途中（198行以降）は赤でも非表示になりません。
２．列のところで
For Each u In ArC()　が、「実行時エラー92 Forループが初期化されていません」となってしまうコードです。

Sub test01()
Dim ArI() As String, ArN() As String, ArR() As String, ArC() As String
Dim i As Long, x As Long, y As Long, n As Long
Dim a As Long, b As Long, k As Long, j As Long
Dim ur As Range, uc As Range
Dim v, u

With ActiveSheet
x = .Cells(1, 1).SpecialCells(xlLastCell).Row
y = .Cells(1, 1).SpecialCells(xlLastCell).Column
' MsgBox x
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
ReDim Preserve ArR(k)
ArR(k) = Join(ArI(), ",")
k = k + 1
Erase ArI()
a = 0
End If

End If
Next i

For Each v In ArR()
If ur Is Nothing Then
Set ur = .Range(v)
Else
Set ur = Union(.Range(v), ur)
End If
Next v

ur.EntireRow.Hidden = True
Set ur = Nothing

For n = 1 To y
If .Cells(1, n).Interior.ColorIndex = 3 Then
ReDim Preserve ArN(b)
ArN(b) = .Cells(1, n).Address(0, 0)
b = b + 1

If b > 20 Or n = y Then
ReDim Preserve ArC(j)
ArC(j) = Join(ArN(), ",")
j = j + 1
Erase ArN()
b = 0
End If

End If
Next n

For Each u In ArC() 'ここでエラー
If uc Is Nothing Then
Set uc = .Range(u)
Else
Set uc = Union(.Range(u), uc)
End If
Next u

uc.EntireColumn.Hidden = True
Set uc = Nothing

End With
End Sub

どこがまずいのでしょうか？
よろしくお願いします。

．

回答No.2

Wendy02

こんばんは。

私には良く分からないですが、ひとつだけ、Application.StatusBar に表示するというのは、遅いという問題があるとしたら、それは余計だと思います。このマクロは、トグルになっていますので、もう一度すれば、戻ります。

'-----------------------------------

Sub 行列非表示R()
　　Dim ArI() As String
　　Dim ArN() As String
　　Dim i As Long, x As Long, y As Long, n As Long
　　Dim a As Long, b As Long, e As Long, f As Long

　　With ActiveSheet
　　　　e = .UsedRange.SpecialCells(xlCellTypeVisible).Rows.Count
　　　　f = .UsedRange.Rows.Count
　　　　x = .Cells(1, 1).SpecialCells(xlLastCell).Row
　　　　y = .Cells(1, 1).SpecialCells(xlLastCell).Column
　　If f <= 1 And y <= 1 Then
　　　 MsgBox "現在のシートの状態ではマクロは不可能かもしれません。", 48
　　　 Exit Sub
　　End If
　　If e <> f Then
　　　'トグルになっている
　　　 .Cells.Rows.RowHeight = .StandardHeight
　　　 .Cells.Columns.ColumnWidth = .StandardWidth
　　　 Exit Sub
　　End If
　　'Main
　　Application.Calculation = xlCalculationManual
　　Application.ScreenUpdating = False
　　　　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
　　　　Next i
　　　　For n = 1 To y
　　　　　　If .Cells(1, n).Interior.ColorIndex = 3 Then
　　　　　　　　ReDim Preserve ArN(b)
　　　　　　　　ArN(b) = .Cells(1, n).Address(0, 0)
　　　　　　　　b = b + 1
　　　　　　End If
　　　　Next n
　　　　.Range(Join(ArI(), ",")).EntireRow.Hidden = True
　　　　.Range(Join(ArN(), ",")).EntireColumn.Hidden = True
　　End With
　　Application.Calculation = xlCalculationAutomatic
　　Application.ScreenUpdating = True
End Sub

お礼

ありがとうございます。

非表示にした行列を表示するのは、

Private Sub 行列表示()
With ActiveSheet
.Cells.EntireRow.Hidden = False
.Cells.EntireColumn.Hidden = False
End With
End Sub

で、瞬時に出来ますのでトグルにする必要はないんでが、そのままやってみたところ、「実行時エラー1004 アプリケーション定義またはオブジェクト定義のエラーです」となってしまいます。
.Range(Join(ArI(), ",")).EntireRow.Hidden = True　がひっかかるようです。どこがわるいのでしょうか？

補足

ちなみにエラーになった.Range(Join(ArI(), ",")).EntireRow.Hidden = True　の、Join(ArI(), ",")の中身は、

A76,A77,A78,A79,A80,A81,A82,A83,A84,A85,A86,A87,A88,A89,A90,A91,A92,A93,A94,A95,A96,A97,A98,A99,A100,A101,A102,A103,A104,A105,A106,A107,A108,A109,A110,A111,A112,A113,A114,A115,A116,A117,A118,A119,A120,A121,A122,A123,A124,A125,A126,A127,A128,A129,A130,A131,A132,A133,A134,A135,A136,A137,A138,A139,A140,A141,A142,A143,A144,A145,A146,A147,A148,A149,A150,A151,A152,A153,A154,A155,A156,A157,A158,A159,A160,A161,A162,A163,A164,A165,A166,A167,A168,A169,A170,A171,A172,A173,A174,A175,A176,A177,A178,A179,A180,A181,A182,A185　　
でした。
多すぎるのでしょうか？

回答No.1

end-u

こんにちは。
Sub try()
　　Dim r As Range
　　Dim x As Long
　　Dim y As Long
　　Dim t As Single '○

　　t = Timer '○
　　Application.Calculation = xlCalculationManual
　　Application.ScreenUpdating = False
　　With ActiveSheet
　　　　.DisplayPageBreaks = False '●
　　　　With .Cells(1).SpecialCells(xlLastCell)
　　　　　　x = .Row
　　　　　　y = .Column
　　　　End With
　　　　For Each r In .Range("A2").Resize(x - 1)
　　　　　　If r.Interior.ColorIndex = 3 Then
　　　　　　　　r.EntireRow.Hidden = True
　　　　　　End If
　　　　　　'Application.StatusBar = r.Row
　　　　Next
　　　　For Each r In .Range("A1").Resize(, y)
　　　　　　If r.Interior.ColorIndex = 3 Then
　　　　　　　　r.EntireColumn.Hidden = True
　　　　　　End If
　　　　　　'Application.StatusBar = r.Column
　　　　Next
　　End With
　　Application.StatusBar = False '""
　　Application.Calculation = xlCalculationAutomatic
　　Application.ScreenUpdating = True
　　Debug.Print Timer - t '○
End Sub

こんな感じではどうでしょう。
列幅行高を弄くる時には●処理があったほうが良いと思います。
また、改ページプレビューの場合はノーマルにしておいたほうが良いでしょう。
○は時間測定なので必要なくなれば削除してください。

お礼

ありがとうございます。
残念ながら時間はほとんどかわりませんでした。