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.14

cj_mover

こんにちは
レスをどうも

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

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

お礼

お返事ありがとうございました。
今回の質問は随分勉強になりました。

> 最善最速のコードでは、連続した矩形範囲ごとのアドレスを合成するロジック

どうやって合成するのか見当もつきませんが、もしお書きになったのがあるのなら今後の参考のため見せていただけるとうれしいです。

回答No.13

cj_mover

重ねて、すみません。

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

回答No.12

cj_mover

すみません。訂正です。

誤り）
＞　i = 1
＞For Each Rg In rngO
＞　i = i + 1
正しくは）
For Each Rg In rngO

以上、訂正をお願いします。
別バージョンの名残って奴です。

失礼しました。

回答No.11

cj_mover

こんにちは
蛇足になりますが、先日の補足がてら、、、

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

お礼

有難うございました。
とても勉強になります。

ためしにテストしてみました。

2行目以降最後（65536）までの偶数行を赤にしてご教示のマクロを走らせたところ、37.42969秒でした。
これに対し、No9で補足欄に書いたマクロでは1959.07秒で比較になりませんね。おどろきました。
これは最速のマシンでやったもので、わたしの端末ではご教示のが45.96484秒、No9の補足欄のはハングアップで計測不能でした。

次に、2行目以降最後（65536）までのすべての行を赤にしてご教示のマクロを走らせたところ、122.5625秒でした。
これに対し、No9で補足欄に書いたマクロでは6.96875秒で逆転です。
シートの状態によってこんなに違うんですね。

回答No.10

Wendy02

こんにちは。

>配列が空でない判定に
>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

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

お礼

何から何までありがとうございました。
とても助かりました。
これからもご指導賜わりますようお願いいたします。

回答No.9

Wendy02

こんにちは。

>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 だけでもよいです。

お礼

> エラーの原因は、配列が空で、エラーが発生して、line:側にJump してしまいます。

ありがとうございます。
そういうことでしたか。

配列での方法は以前の方法とは比較にならないくらい早いのでこれで行こうと思います。
ただ、エラー時にはエラーハンドラーに飛ばしたいのでOn Error Resume Next　を使用せず、配列が空でないときのみUnionを使うようにしてみました。
配列が空でない判定に
If Join(ArR(), ",") <> "" Then
としてみましたがこれであってますでしょうか？なんどもすみませんこれで最後の質問にします。

現在のコードはまた補足欄に記入しました。

補足

現在のコードです。

Sub 行列非表示()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

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

On Error GoTo line

With ActiveSheet

x = .Cells(1, 1).SpecialCells(xlLastCell).Row
y = .Cells(1, 1).SpecialCells(xlLastCell).Column

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 > 30 Or i = x Then

ReDim Preserve ArR(k)
ArR(k) = Join(ArI(), ",")
k = k + 1
' Sheet2.Cells(k, 1) = Join(ArI(), ",")
Erase ArI()
a = 0
End If

Next i

If Join(ArR(), ",") <> "" Then

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

End If

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

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

Next n

If Join(ArC(), ",") <> "" Then

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 If

End With

line:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True

MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure 行列非表示 of Module1"

End Sub

よろしくおねがいします。

(o。_。)o

回答No.8

cj_mover

こんにちは

　　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しますが、わりと特殊な方法ですし、
完全というのでもないので躊躇います。

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

お礼

> Worksheet_SelectionChange　イベントが発生するようです。

ほんとですね、ありがとうございました。

回答No.7

Wendy02

こんにちは。

こういうようになるのでは？

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
の構文は、前者に対して、従属した構文ではないと思います。

お礼

ありがとうございます。
おかげでなんとか先に進めましたが、まだ以下の問題があり対処できずにおります。

1行目の列方向にしか赤いセルがないと（A列２行目以降に赤いセルが存在しない場合）非表示にならない。

A列2行目以下にしか赤いセルがないと（1行目A列以降に赤いセルが存在しない場合）非表示にならない。

これが解決したら完璧なのですが・・・・。
どう変えたらよいのやら見当もつかずにおります。
コードは補足欄に記入します。
なにとぞよろしくお願い申し上げます。

補足

これが現在のコードです。

Sub 行列非表示()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

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

On Error GoTo line

With ActiveSheet

x = .Cells(1, 1).SpecialCells(xlLastCell).Row
y = .Cells(1, 1).SpecialCells(xlLastCell).Column

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 > 30 Or i = x Then
ReDim Preserve ArR(k)
ArR(k) = Join(ArI(), ",")
k = k + 1
Erase ArI()
a = 0
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

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

If b > 30 Or n = y Then
ReDim Preserve ArC(j)
ArC(j) = Join(ArN(), ",")
j = j + 1
Erase ArN()
b = 0
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

Debug.Print u
Next u

ur.EntireRow.Hidden = True
uc.EntireColumn.Hidden = True

Set ur = Nothing
Set uc = Nothing

End With

line:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

回答No.6

Wendy02

こんばんは。

>どこがまずいのでしょうか？
>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を調べたら日本語がなくなりました）からすると、片方が終わったら次ではなく、全部、まとめて一気に非表示したほうがよいです。

お礼

ありがとうございます。

> If a > 20 Or i = x Then　'←これは、上のIf ～ End If 構文とは別のものですから、ネスト出来ません。

ずっと悩んでいるのですが理解できません。
赤いセルをカウントしているのがaですよね、ならばどこにいれたらよいのでしょうか？

回答No.5

higekuman

#4さんへの補足に書いてある「削除したシート」はもう無いのでしょうか？
もしあれば、そのシートをアクティブにして、
MsgBox ActiveSheet.Shapes.Count
を試してみたら、もしかしたらものすごい数字が出てくるかも。

お礼

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