みんなの「教えて(疑問・質問)」にみんなで「答える」Q&Aコミュニティ

こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

エクセル2000です。

以下は、ワークシートのA列の2行目以降に赤(Interior.ColorIndex = 3 )のセルがあればその行を非表示に、1行目の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

投稿日時 - 2008-05-08 18:08:02

QNo.4007086

困ってます

質問者が選んだベストアンサー

 こんにちは
せっかくだからもう少し、、、なんて、また考え出したらキリがなくて、、、
結局殆ど元通り、完全ではありませんが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

' '【c1】セル範囲を走査し、判定をブール型の配列に

  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

' '【c2】ブール型配列から参照文字列を範囲毎に","区切りで列挙

  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)

' '【c3】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 = ""

' '【c4】配列毎に参照文字列で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

' '【r1】

  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

' '【r2】

  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)

' '【r3】

  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 = ""

' '【r4】

  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 プロパティを取得するより、書いた方が実は速かったりするのです。
  【1】から【3】の部分は【1】のFor Eachの中に纏めることもできるのですが、
  分岐が複雑になり、かえって遅くなりますし、記述も長くなります。
  【1】と【2】のループ中の条件分岐は、書き方が山ほどありますが。
  平凡に見えるこのやり方が、このコードの一番のポイントです。
  「判定がFalseなら、何もしないで即、Next」ということだけですけれど。

  【3】に出てくる Mid は、Mid()関数ではなく、Mid ステートメントです。

  ◆↓ から ◆↑ の部分は無くもそのまま使えます。(長いけど(^^;)
  非表示にする範囲各々の行や列が、「単独」か「連続」か、
  その割合によっては無い方が速い場合もあります。
  (↑テスト用の極端なシート等では特に)
  バランスよくする為だけにある記述です。


  この他に、作業セルに判定を書いて(非表示の場合だけTRUEなどにして)
  .SpecialCells(Type:=xlCellTypeConstants, Value:=xlLogical).EntireColumn
  で非表示にする方法も条件によってはより速い場合もあります。
  やはり配列を使って、判定を一括でシートにはき出して消す方法ですが、
  一般的な実務で考えたら、そちらの方が良いかも知れませんね。

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

投稿日時 - 2008-05-15 16:17:40

お礼

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

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

投稿日時 - 2008-05-15 18:23:56

ANo.15

このQ&Aは役に立ちましたか?

3人が「このQ&Aが役に立った」と投票しています

回答(15)

ANo.14

こんにちは
レスをどうも

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

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

投稿日時 - 2008-05-13 13:31:52

お礼

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

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

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

投稿日時 - 2008-05-13 14:18:10

ANo.13

重ねて、すみません。

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

投稿日時 - 2008-05-12 21:35:53

ANo.12

すみません。訂正です。

誤り)
> i = 1
>For Each Rg In rngO
> i = i + 1
正しくは)
For Each Rg In rngO

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

失礼しました。

投稿日時 - 2008-05-12 15:00:39

ANo.11

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

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

'ーーーーーーーーーーー列ーーーーーーーーーーー
'【1】対象セルの参照文字列を列挙
 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)
'【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, ";")
'【3】参照文字列の配列毎に (列を)隠す
 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

投稿日時 - 2008-05-12 14:36:12

お礼

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

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

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

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

投稿日時 - 2008-05-13 11:16:10

ANo.10

こんにちは。

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

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

投稿日時 - 2008-05-12 14:08:40

お礼

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

投稿日時 - 2008-05-12 16:20:45

ANo.9

こんにちは。

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

なるほどね、でも、今回も、惜しいですね。(こういう言い方は、ヒンシュクものかも(^^;)

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

投稿日時 - 2008-05-11 11:44:41

補足

現在のコードです。

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

投稿日時 - 2008-05-11 17:43:29

お礼

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

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

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

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

投稿日時 - 2008-05-11 17:41:33

ANo.8

こんにちは

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

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

投稿日時 - 2008-05-11 08:02:48

お礼

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

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

投稿日時 - 2008-05-11 17:23:53

ANo.7

こんにちは。

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

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

投稿日時 - 2008-05-10 10:38:40

補足

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

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

投稿日時 - 2008-05-10 12:21:34

お礼

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

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

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

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

投稿日時 - 2008-05-10 12:33:26

ANo.6

こんばんは。

>どこがまずいのでしょうか?
>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

>1.行が途中(198行以降)は赤でも非表示になりません。
>2.列のところで

1.2. は直るのですが、後、「最適化原則」(MSDNを調べたら日本語がなくなりました)からすると、片方が終わったら次ではなく、全部、まとめて一気に非表示したほうがよいです。

投稿日時 - 2008-05-09 23:04:44

お礼

ありがとうございます。

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

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

投稿日時 - 2008-05-10 00:56:48

ANo.5

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

投稿日時 - 2008-05-09 16:28:58

お礼

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

投稿日時 - 2008-05-09 17:17:43

ANo.4

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

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

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

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

投稿日時 - 2008-05-09 12:38:34

補足

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

( ̄~ ̄;)う~ん  何なんだ、これは・・・・。

投稿日時 - 2008-05-09 16:15:57

お礼

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

投稿日時 - 2008-05-09 15:26:04

ANo.3

こんにちは。

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

投稿日時 - 2008-05-09 11:05:34

補足

1.行が途中(198行以降)は赤でも非表示になりません。
2.列のところで
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:54

お礼

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

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

投稿日時 - 2008-05-09 13:40:17

ANo.2

こんばんは。

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

投稿日時 - 2008-05-08 20:25:38

補足

ちなみにエラーになった.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:08

お礼

ありがとうございます。

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

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:28

ANo.1

こんにちは。
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-08 19:02:25

お礼

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

投稿日時 - 2008-05-09 10:12:30

あなたにオススメの質問