このマクロを高速化させるにはどうすればいいですか？

質問

VBA初心者で、とりあえず頑張って作ってみました。以下のVBAでの修正点を教えてください。
（英単語の小テスト用につくりました。）

Range("C3:E22,H3:J22").Select
Selection.Font.ColorIndex = 2
Selection.Interior.ColorIndex = 2
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
' ここまでは、共通の動作
Range("A1").Select
ActiveCell.FormulaR1C1 = "20"
' 問題数に応じて、数字を変更
Range("C3:E22,H3:J22").Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
' 罫線を引く
Range("D3:E22,I3:J22").Select
Selection.Font.ColorIndex = 1
' 文字を黒くする
Range("C3:C22,H3:H22").Select
Selection.Interior.ColorIndex = 16
' セルをグレーにする
Rows("3:18").Select
Selection.RowHeight = 31.5
' セルの幅を指定
ActiveSheet.PageSetup.PrintArea = "$B$1:$K$25"
' 印刷範囲を指定
Range("U3:U42").Select
Selection.ClearContents
' 四線を消去
Range("D3:D4").Select
Calculate
' 再計算完了

宜しくお願いします。
また、このVBAは慣れている人から見ると何点くらいですか？（感覚で結構です）

回答No.3

fumufumu_2006 · ベストアンサー

根本的な話ですが・・・
罫線引くのにそんなに時間かかりますか？
試した限りでは、質問のプログラムは一瞬で終わりますが・・・
他にも計算式などがあるようなので、新規のブックで質問のプログラムだけを動かしても、秒単位で時間がかかりますか？

各処理（Range(??).Selectから次のRange(??).Selectまでの部分、再計算も1つとして）だけにして実行して、どの部分が一番時間がかかりますか？
または、質問のプログラムのコメントの位置でmsgboxすると、ちょうどいいかもしれません。
Range("C3:E22,H3:J22").Select
・・・
' ここまでは、共通の動作
MsgBox "ここまでは、共通の動作"
Range("A1").Select
ActiveCell.FormulaR1C1 = "20"
' 問題数に応じて、数字を変更
MsgBox "問題数に応じて、数字を変更"
Range("C3:E22,H3:J22").Select
・・・
' 四線を消去
MsgBox "四線を消去"
Range("D3:D4").Select
Calculate
' 再計算完了
MsgBox "再計算完了"
として、どの部分が一番時間がかかりますか？

もしかしたら、見えない何かがありませんか？
Sub check()
MsgBox Shapes.Count
End Sub
とかしたら、いくつ表示しますか？
いらないshapeがあるようなら、消してみてはどうでしょうか？
下は全部のシェープを消します。
Sub check()
Shapes.SelectAll
Selection.Delete
End Sub
その状態ではどれくらい時間がかかりますか？

補足

今、もう一度動作確認したら、10秒弱に縮まっていました。
なぜ短縮されたかわからないですが・・・（昨日の夜から何も変えてないのに）
一般的にこの10秒弱の動作は遅いものなのでしょうか？
あと、
Sub check()
MsgBox Shapes.Count
End Sub
これやってみましたが、エラーになりました・・・

回答No.8

fumufumu_2006

サンプルではそれほど時間がかからない（遅い所でも１秒前後）のですが、１０秒（数秒）単位で時間がかかりますか？
細かい事は別にして、それほど高速化はできないみたいでした。

お礼

わかりました。
何度もありがとうございました。

回答No.7

fumufumu_2006

質問のプログラムの各処理にがかかる時間を表示します。
最初のApplication.ScreenUpdatingは、ある場合と無い場合で違いを見てください。
特に時間がかかっている処理が無くてApplication.ScreenUpdatingのある場合が早いなら、何か全体を遅くしている表示関係の処理があるので、新たなブックに作り直すのが一番いいと思います。

'Application.ScreenUpdating = False '実行する場合としない場合でトータル時間の差を見る
Dim msg As String
Dim t As Single
Dim tt As Single
tt = Timer
t = Timer
Range("C3:E22,H3:J22").Select
Selection.Font.ColorIndex = 2
Selection.Interior.ColorIndex = 2
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
' ここまでは、共通の動作
msg = msg & "ここまでは、共通の動作=" & Format(Timer - t, "0.00") & vbCrLf: t = Timer
Range("A1").Select
ActiveCell.FormulaR1C1 = "20"
' 問題数に応じて、数字を変更
msg = msg & "問題数に応じて、数字を変更=" & Format(Timer - t, "0.00") & vbCrLf: t = Timer
Range("C3:E22,H3:J22").Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
' 罫線を引く
msg = msg & "罫線を引く=" & Format(Timer - t, "0.00") & vbCrLf: t = Timer
Range("D3:E22,I3:J22").Select
Selection.Font.ColorIndex = 1
' 文字を黒くする
msg = msg & "文字を黒くする=" & Format(Timer - t, "0.00") & vbCrLf: t = Timer
Range("C3:C22,H3:H22").Select
Selection.Interior.ColorIndex = 16
' セルをグレーにする
msg = msg & "セルをグレーにする=" & Format(Timer - t, "0.00") & vbCrLf: t = Timer
Rows("3:18").Select
Selection.RowHeight = 31.5
' セルの幅を指定
msg = msg & "セルの幅を指定=" & Format(Timer - t, "0.00") & vbCrLf: t = Timer
ActiveSheet.PageSetup.PrintArea = "$B$1:$K$25"
' 印刷範囲を指定
msg = msg & "印刷範囲を指定=" & Format(Timer - t, "0.00") & vbCrLf: t = Timer
Range("U3:U42").Select
Selection.ClearContents
' 四線を消去
msg = msg & "四線を消去=" & Format(Timer - t, "0.00") & vbCrLf: t = Timer
Range("D3:D4").Select
Calculate
' 再計算完了
msg = msg & "再計算完了=" & Format(Timer - t, "0.00") & vbCrLf: t = Timer
msg = msg & "TotalTime=" & Format(Timer - tt, "0.00")
Application.ScreenUpdating = True
MsgBox msg

補足

教えていただいたものを新しいブックで試した結果、
両方とも差はありませんでした。
また、偏って時間がかかることもありませんでした。
自分が作ったサンプルをのせたので、見てもらえますか？
http://briefcase.yahoo.co.jp/bc/add0804/lst?.dir=/%a5%de%a5%a4%a5%c9%a5%ad%a5%e5%a5%e1%a5%f3%a5%c8

回答No.6

fumufumu_2006

>MsgBox ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas).Count
>を試した結果、１８２でした。しかし、どれも必要な数式なので
>限界ですかね。
どんな数式かわかりませんが、１８２個程度ではそんなに時間はかからないと思います。
F8で、１ステップずつ実行してみた結果はどうだったのでしょうか？
納得されたならいいですが、たぶん原因は違う所にあると思います。

補足

F8をやってみた結果、どの過程でも1秒未満ですぐ動作しました。
しかし、全体を通して実行するとやはり１０秒程度かかります。
（１つ１つの動作を合計しても２秒はかかりませんでした）
どうしてですかね？・・・

回答No.5

fumufumu_2006

ANo.4です。

>確かに新しいブックだと1秒くらいでできました。
>ってことは遅い原因はエクセルの関数ってことですか？
F8で、１ステップずつ実行してみてください。
異常に時間がかかる部分がわかるはずです。
見えない大量のシェープがあるのかと思いましたが、３５個程度ならたぶん問題なと思います。
最後の再計算が遅いのかもしれませんが、質問の内容から１０秒もかかるような作業になるとは思えません。
ちなみに、
MsgBox ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas).Count
で、シート中の計算式のセルの個数がわかるので、極端に多いようならそのせいかもしれません。

>あと、「MsgBox ActiveSheet.Shapes.Count」やってみたら
>「３５」って出ました。
>これはどういうことですか？
テキストボックスや図形などが３５個あるということです。
表示関係が極端に遅くなったり、ファイルサイズが巨大になる原因になるようです。
35個程度なら問題はないと思いますが、覚えがないなら、下記で削除してください。
ActiveSheet.Shapes.SelectAll
Selection.Delete

表示関係で遅い場合、最初に
Application.ScreenUpdating = False
最後に
Application.ScreenUpdating = True
を入れると、速くなる場合もあります。

どうしても遅くなる理由がわからない場合は、新しいシートに作り直して見るというのが一番早いかもしれません。

お礼

長時間ありがうございました。
細かく教えていただいたおかげで、徐々にわかってきました。
最後に、
MsgBox ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas).Count
を試した結果、１８２でした。しかし、どれも必要な数式なので
限界ですかね。

回答No.4

fumufumu_2006

ANo.3です。

>一般的にこの10秒弱の動作は遅いものなのでしょうか？
新しいブックに質問のプログラムだけだと、１秒はかからないと思います。（たぶん）
新しいブックで、質問のプログラムを動かしたらどうなりますか？

>Sub check()
>MsgBox Shapes.Count
>End Sub
>これやってみましたが、エラーになりました・・・
すみません、以下ではどうでしょうか？
MsgBox ActiveSheet.Shapes.Count
または、シート名がSheet1なら
MsgBox Worksheets("Sheet1").Shapes.Count

補足

確かに新しいブックだと1秒くらいでできました。
ってことは遅い原因はエクセルの関数ってことですか？
あと、「MsgBox ActiveSheet.Shapes.Count」やってみたら
「３５」って出ました。
これはどういうことですか？

回答No.2

hana-hana3

＞ちなみに、「根本的に書き換えてもっと早く動作する」なんてことはできるんですか？

仕様によります。

１．最初の初期化は必用なのか？
２．罫線の設定は必用なのか？
３．セル幅（高さ）の設定は必用なのか？
４．印刷範囲の設定は必用なのか？
５．四線を消去は必用なのか？
６．再計算は必用なのか？

無駄（不要）と思う部分を削除するか、別の方法で行うかの問題になります。
何が必用で、何が不要なのかがはっきりしないので何とも言えませんし、何度も実行するマクロでも無いとおもいます。
（１度実行すれば目的は達成される）

補足

まず、このマクロを使っているシートについて説明します。
英単語の小テスト（印刷して配布）を作るためのものです。
問題数は5問・10問・15問・20問の4パターン作る予定です。
問題はエクセルの関数でランダムに表示されるようになっています。
この前提で

１、初期化は問題数によって罫線や表示している問題数が違うため
　　必要です。
２、同上。
３、問題数によってセルの幅が変わる（1枚のシートに入るようにする）
　　ため必要。
４、問題数によって印刷範囲が変わるため、必要。
５、「四線」とは英語の4線のことですが、ワードアートのリンクで
　　表示されるようにしているため、解答を表示するときに必要。
６、再計算は、問題が勝手に変わらないように、手動で計算という
　　設定になっているため、問題数が変わったときに
　　シート内の関数を反映させるためには必要。

いちいち問題を作るのが面倒なので、いっそのことマクロでと
思ったのですが、動作が遅いのは仕方がないのですかね？
ちなみに修正したら15秒までは早くなりました。
宜しくお願いします。

回答No.1

hana-hana3

短くするならこれだけ。

With Range("C3:E22,H3:J22")
.Font.ColorIndex = 2
.Interior.ColorIndex = 2
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
End With
' ここまでは、共通の動作

Range("A1") = 20
' 問題数に応じて、数字を変更
With Range("C3:E22,H3:J22")
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Font.ColorIndex = 1
' 文字を黒くする
.Interior.ColorIndex = 16
' セルをグレーにする
End With

Rows("3:18").RowHeight = 31.5
' セルの幅を指定

' 罫線を引く
ActiveSheet.PageSetup.PrintArea = "$B$1:$K$25"
' 印刷範囲を指定
Range("U3:U42").ClearContents
' 四線を消去
Range("D3:D4").Select
Calculate
' 再計算完了

＞このVBAは慣れている人から見ると何点くらいですか？（感覚で結構です）

記録マクロそのままみたいですから・・・

お礼

ありがとうございました！
動作時間が30秒→20秒に短縮されました！！
ちなみに、「根本的に書き換えてもっと早く動作する」
なんてことはできるんですか？