Excel マクロの実行が途中で止まり（応答なし）になるのですが・・・

質問

単純な１行おきに色を付けるマクロなのですが、
実行すると400件位は処理するのですが、そこで固まってしまいます。
1.5MB のデータで15000件位あります。
タスクマネージャのCPU使用率は100%になってます。
どのように対応すればよいか、ご教授お願いします。

回答No.9

KenKen_SP · ベストアンサー

こんばんは。KenKen_SP です。

条件付き書式を使えば？

Sub Sample1()

　　' テストデータをセット
　　Cells.Delete
　　Range("A1:A15000").Value = "TestData"

　　MsgBox "条件付き書式で１行置きにセルを着色します", vbInformation

　　Application.ScreenUpdating = False
　　' 条件付き書式をセット
　　ActiveSheet.Cells.FormatConditions.Delete
　　With ActiveSheet.UsedRange.EntireRow.FormatConditions
　　　　With .Add(Type:=xlExpression, Formula1:="=(MOD(ROW(),2)=0)")
　　　　　　.Interior.ColorIndex = 34
　　　　End With
　　　　With .Add(Type:=xlExpression, Formula1:="=(MOD(ROW(),2)>0)")
　　　　　　.Interior.ColorIndex = 36
　　　　End With
　　End With
　　Application.ScreenUpdating = True

End Sub

ご提示のコードで言えば、一行ずつ色を変えてくのではなく、

　　1.　一度最終セルまでの全体を色１で着色
　　2.　For～Next を使って １行飛ばしで色２で着色

とすると結果は同じでも、低速な Range オブジェクトへのアクセス数が約半分
に減らせますよ。

Sub Sample2()

　　Dim lLastRownum As Long
　　Dim i　　　　　 As Long

　　' テストデータをセット
　　Cells.Delete
　　Range("A1:A15000").Value = "TestData"

　　MsgBox "全体を着色してから１行置きに着色し直します", vbInformation

　　Application.ScreenUpdating = False
　　lLastRownum = Cells(Rows.Count, "A").End(xlUp).Row
　　Range("A1", Cells(lLastRownum, "A")).EntireRow.Interior.ColorIndex = 34
　　For i = 1 To lLastRownum Step 2
　　　　Rows(i).Interior.ColorIndex = 36
　　Next i
　　Application.ScreenUpdating = True

End Sub

お礼

回答ありがとうございます。柔軟な発想力見事です。恐れ入りました。

回答No.10

zap35

#01です。マクロのUPありがとうございました。
少し目先を変えてみました。15,000行でも一瞬で終わると思います。
ただし行数が１行しか無いときなどのエラー処理は入れていません。

Private Sub CommandButton1_Click()
Dim IRO_1 As Integer
Dim IRO_2 As Integer

　IRO_1 = TextBox1.Text
　IRO_2 = TextBox2.Text
　Range("A1").Interior.ColorIndex = IRO_2
　Range("A2").Interior.ColorIndex = IRO_1
　Range("A1:A2").Copy
　Rows("1:" & Range("A65536").End(xlUp).Row).Select
　Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
　　SkipBlanks:=False, Transpose:=False
　Application.CutCopyMode = False
End Sub

お礼

回答ありがとうございます。色々な手法がありますね。条件付書式初めて知りました。勉強になります。

回答No.8

taocat

こんばんは。

原因は、Select。
行Select,色付け、行Select,色づけ・・・
おい、おい、という感じでCPUが慌てふためいて・(^^;;;
今回のような場合はSelectは必要ありませんので外しましょう。

--------------------------------------------------------
Private Sub CommandButton1_Click()

　Dim IRO_1 As Variant
　Dim IRO_2 As Variant
　Dim i As Integer
　Dim WK_RESULT As Integer

　IRO_1 = Val(TextBox1.Text)
　IRO_2 = Val(TextBox2.Text)

　i = 1

　Do While Cells(i, 1) <> ""

　　　WK_RESULT = i Mod 2

　　　If WK_RESULT = 0 Then
　　　　　Rows(i).Interior.ColorIndex = IRO_1
　　　Else
　　　　　Rows(i).Interior.ColorIndex = IRO_2
　　　End If

　　　i = i + 1

　Loop

End Sub
-------------------------------------------------------

これに限らず、不要なSelectはしないようにしましょう。
以上です。

お礼

回答ありがとうございます。最小限での修正、的確なアドバイス、感服いたしました。

回答No.7

Wendy02

こんばんは。

>タスクマネージャのCPU使用率は100%になってます。

あながち、CPU使用率の一瞬100%になる場合は気にしなくてよいのですが、ブックのOLEやDDEの問題とかありますので、ずっと、そのままになってしまう場合は、そういう他とつながっているものを疑ってよいと思います。

また、Excel2000 ということですと、配列数式の累計演算セル数の約5,500個を越える部分に、エラーを起こす元があるようですから、数式には気をつけたほうがよいです。また同様に、書式も、累計数の問題でエラーがありますから、このような、一個ずつ色づけする方法は、あまり芳しくありません。まとめて色を塗るというのが鉄則です。しかし、それでも、1.5M ファイルサイズがあって、なお、列全体に色をつけてしまうというのは、書式を使って範囲を広げることですから、全体的なワークシートの使い方の考え方としては無理があります。

とはいえ、このような場合は、AutoFilter などを使うと良いようです。なぜか、負担が少ないようです。ともかく、以下で試してみてください。

なお、変数　i 　は、Long型です。

'---------------------------------------------------------------
Private Sub CommandButton1_Click()
Dim Iro_1 As Integer
Dim Iro_2 As Integer
Dim i As Long
On Error GoTo ErrHandler
Iro_1 = TextBox1.Text
Iro_2 = TextBox2.Text
Application.ScreenUpdating = False
With ActiveSheet
　 i = Range("A65536").End(xlUp).Row
　 With .Range(.Cells(1, 256), .Cells(i, 256))
　　　 .FormulaLocal = "=MOD(ROW(),2)"
　　　 .AutoFilter Field:=1, Criteria1:="0"
　　　 .EntireRow.SpecialCells(xlCellTypeVisible).Interior.ColorIndex = Iro_1
　　　 .AutoFilter Field:=1, Criteria1:="1"
　　　 .EntireRow.SpecialCells(xlCellTypeVisible).Interior.ColorIndex = Iro_2
　　　 .AutoFilter
　　　 .ClearContents
　 End With
End With
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
　　MsgBox Err.Number & ": " & Err.Description
End Sub

お礼

回答ありがとうございます。コピーさせてもらい実行したのですがちょっと上手くいきませんでした・・・ちょっと間違えたかもしれませんが・・貴重なご意見参考にさせてもらいます。

回答No.6

tinu 2000（@tinu2000）

Ano4です。
（；￢＿￢） ぁ ゃι ぃ
を取り消します。(^^ゞ

実際にソースを貼り付けて実行して見ました。
IRO_1 = 2
IRO_2 = 4
に変更して、

　　i = i + 1
　　DoEvents
Loop
End
End Sub
とLoopの前に DoEvents と End Subの前に End を付けて実行しました。

問題なく１行置きに色がつきましたねぇ・・・
但し、3000行までで、700Hzの5年ほど前のノートPCです。

という事で、ソースは問題ありません。
という事は、メモリは大丈夫ですか？いくつを積んでいますか？

お礼

回答ありがとうございます。多くの方に教えていただき、無事解決致しました。

回答No.5

imogasi

１セルごとに、同じにしろ、違うにしろ、条件付書式を多数セルに設定すると、メモリを食うというのを読んだことがあります。上限もあったように記憶します。
小生はInsideエクセルは不確かですが、１セルもRangeで１つですが、それに対O応する書式をメモリに網羅して記憶するはずで、記憶単位はRangeだと思うのです。
（１）なるべく同じ条件付き書式なら、セル範囲で設定する。
（２）データ内容の変化に瞬時にたいおうできないが、書式をV条件をVBAで切り分け、対応した書式をVBAで設定するのはどうでしょう。
（３）（２）を進めてChangeイベントでデータの変化を捉えたとき
（２）と同じ判別と書式設定のルーチンを通す
のはどうでしょう。

お礼

回答ありがとうございます。多くの方に教えていただき、無事解決致しました。

回答No.4

tinu 2000（@tinu2000）

ここはソース公開が手っ取り早いですね。
自分も他の方もソースが（；￢＿￢） ぁ ゃι ぃ
と睨んでいます。

ソースに問題が無ければ、別の方向に目が向けれますしね。

補足

ANO.1にソースを貼り付けて見ましたのでお願いします。

回答No.3

starsip

一番良いのは最新のマシンに
替える事でしょうか？

CPUが100%超えているという事ですよね。

私もExcelを使っていますが、私事で言えば
自宅の2000と会社の2003では機能が違うし、

自宅のADSLと会社のCATVでは速度も違います。

私は判っている（つもりです）ので
もし、自宅が固まっても問題ありません。
（判ってます・・PC古いし、速度も出ないし・・
固まった場合の対処とか・・））

固まるのがいやであれば、とりあえず一番いい方法は
最新マシンを購入でしょうか。

私もお金さえあれば、最新PC購入が夢ですね。

お礼

回答ありがとうございます。
EXCEL2000なのですが、会社のＰＣで結構新しいものなのですが・・・
何回か実行して３８５件目とか３９２、４００位とか４００件前後で必ず固まるんです。件数少ない時は正常に終わっていたはずなんですが。

回答No.2

mshr1962

＞単純な１行おきに色を付けるマクロなのですが、
条件付き書式を使うとか、2行選択して書式のコピーしたほうが早い気がしますが．．．

＞実行すると400件位は処理するのですが、そこで固まってしまいます。
マクロのコードが分らないと適切な回答は付きませんよ。
現状で考えられるのは、変数が多すぎるとか、ループの仕方に問題があるとかですが．．．

＞1.5MB のデータで15000件位あります。
＞タスクマネージャのCPU使用率は100%になってます。
とりあえずでなら、ブックをコピーして500件位で試してみて同じ症状がでるか確認してください。
そこででないならメモリ容量の問題の可能性が高いです。
逆に同じ症状があるなら、マクロのコードに無駄・無理があります。
その場合は補足にでもコードを公開して確認できるようにしてください。

お礼

回答ありがとうございます。多くの方に教えていただき、無事解決致しました。

補足

ANO.1にソースを貼り付けて見ましたのでお願いします。

回答No.1

zap35

「固まる」とありますがCPU使用率が100％だとすると固まっている（フリーズしている）のではなくループしている可能性もありますね。

ループの終了判定にIntegerの変数を使用して、桁落ちしたりしていませんか？
マクロを補足に掲載してみれば具体的な回答が得られるかもしれませんよ。

なお1行おきに色を付けるだけなら条件付き書式で「=MOD(ROW(),2)=0」という式を使って、書式で背景色を指定すれ方法でも実現できます。

補足

フォームを使っていてボタンを押下するとこんな感じなのですが・・・

Private Sub CommandButton1_Click()
Dim IRO_1 As Integer
Dim IRO_2 As Integer
Dim i As Integer
IRO_1 = TextBox1.Text
IRO_2 = TextBox2.Text
i = 1

--------Do While ActiveSheet.Cells(i, 1) <> ""
-----------WK_RESULT = i Mod 2
-----------If WK_RESULT = 0 Then
--------------ActiveSheet.Rows(i).Select
-----------------With Selection.Interior
----------------------.ColorIndex = IRO_1
----------------------.Pattern = xlSolid
----------------------.PatternColorIndex = xlAutomatic
-----------------End With
-----------Else
--------------ActiveSheet.Rows(i).Select
-----------------With Selection.Interior
----------------------.ColorIndex = IRO_2
----------------------.Pattern = xlSolid
----------------------.PatternColorIndex = xlAutomatic
-----------------End With
-----------End If
-----------i = i + 1

--------Loop

End Sub