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.5 回答者： higekuman 回答日時： 2008/05/09 16:28

#4さんへの補足に書いてある「削除したシート」はもう無いのでしょうか？

もしあれば、そのシートをアクティブにして、
MsgBox ActiveSheet.Shapes.Count
を試してみたら、もしかしたらものすごい数字が出てくるかも。

この回答へのお礼

ありがとうございます。
もちろんオリジナルのコピーをとって試してますので調べられますよ。
先ほどデータもオブジェクトも無いと書いたと思いますが、念のためやってみました。
カウントは１で、なんだろうと思い調べたらコメントが１つありました。

お礼日時：2008/05/09 17:17

No.4 回答者： end-u 回答日時： 2008/05/09 12:38

>残念ながら時間はほとんどかわりませんでした。

そうですか。では、あとコードで制御可能なのは
Application.EnableEvents の制御くらいしか思いつきません。お力になれずすみませんm(_ _)m

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

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

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

この回答への補足

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

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

補足日時：2008/05/09 16:15

この回答へのお礼

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

お礼日時：2008/05/09 15:26

No.3 回答者： Wendy02 回答日時： 2008/05/09 11:05

こんにちは。

>そのままやってみたところ、「実行時エラー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の中では、セルに頻繁にアクセスしないこと。
というものがあります。一旦、配列や文字列で取得してから、一気に、セル(行・列含む）を取得すればよいわけです。

この回答への補足

１．行が途中（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

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

．

補足日時：2008/05/09 13:43

この回答へのお礼

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

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

お礼日時：2008/05/09 13:40

No.2 回答者： Wendy02 回答日時： 2008/05/08 20:25

こんばんは。

私には良く分からないですが、ひとつだけ、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

この回答への補足

ちなみにエラーになった.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　　
でした。
多すぎるのでしょうか？

補足日時：2008/05/09 10:36

この回答へのお礼

ありがとうございます。

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

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

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

お礼日時：2008/05/09 10:21

No.1 回答者： end-u 回答日時： 2008/05/08 19:02

こんにちは。

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

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

この回答へのお礼

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

お礼日時：2008/05/09 10:12