マクロVBAの高速化・速度対策の具体的手順と検証
マクロVBAが遅い・重いという相談が非常に多いので、
ここでのまとめとしては、
まずやるべき事は、
Excel 2010 のパフォーマンス・・・VBA マクロの高速化
VBA高速化テクニック・・・セルを配列に入れる
この部分になります。
マクロVBAが遅いと相談されて、コードを確認した場合、
ほとんどは、以下の対処で劇的に速くなります。
・Application.ScreenUpdatingの停止・Applicationの主要プロパティ ・ScreenUpdating(マクロVBAの高速化) ・DisplayAlerts(警告停止) ・Interactive(ユーザー操作の禁止) ・Calculation(計算方法) ・StatusBar ・Cursor ・その他
・Application.Calculationを手動・Applicationの主要プロパティ ・ScreenUpdating(マクロVBAの高速化) ・DisplayAlerts(警告停止) ・Interactive(ユーザー操作の禁止) ・Calculation(計算方法) ・StatusBar ・Cursor ・その他
・セルを配列に入れる・セル範囲⇔配列の基本VBA ・使用例 ・配列およびマクロVBAの高速化に関するページ
また、単なるテクニックではなく、正しいロジック・アルゴリズムによっても大きく変わります。
【奥義】大量データでの高速VLOOKUP
この記事は、マクロVBAではなく、ワークシート関数についてですが、
考え方の問題として、非常に重要です。
データの検索はVBAでは頻繁に行われます。
データを並べ替え、適切なアルゴリズムで格段に速くなります。
VBAの速度対策としては、ここに書いた事がほとんど全てなのですが、



Sheet1
データは1万件、2~10002行まで入っています。
C2 =VLOOKUP($B2,Sheet3!$A:$D,2,0)
E2 =C2*D2
全行に同様の数式が入れてあります。
Sheet2
Sheet3
とりあえず10件入れました。
D2 =SUMIF(Sheet1!B:B,A2,Sheet1!D:D)
E2 =SUMIF(Sheet1!B:B,A2,Sheet1!E:E)
全行に同様の数式が入れてあります。
作るVBAの内容
出力されたデータ範囲には罫線を引きます。
A列は、日付形式の表示形式を設定
E列は、カンマ編集
検証環境
Core2DUO 1.66GHz
メモリ 1GB
Excel2010
かなり古いPCです・・・
以下11通りのVBAでかかった時間を実測しました。
動作の安定度等もある為、若干の違いは誤差として判断して下さい。
なお、実測は3回以上の平均を出しています。
各VBAの先頭と最後に
Debug.Print Timer
を入れ、その差を持って所要時間としています。
test1
さすがに、このサイトを見ている人では、
こんなコードを書く人はいないと信じたい。
Sub test1()
Debug.Print Timer
Dim i, j
Sheets("Sheet2").Select
Range("A3").CurrentRegion.Offset(1).Clear
j = 4
Sheets("Sheet1").Select
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 2) = Worksheets("Sheet2").Range("B1") Then
Range("A" & i & ":" & "E" & i).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A" & j).Select
ActiveSheet.Paste
Range("A" & j).NumberFormatLocal = "yyyy/m/d"
Range("E" & j).NumberFormatLocal = "#,##0"
Range("A" & i & ":" & "E" & i).Borders.LineStyle = xlContinuous
Sheets("Sheet1").Select
j = j + 1
End If
Next
Sheets("Sheet2").Select
Debug.Print Timer
End Sub
test2
Application.ScreenUpdating = False
これ一発で速くなります。
Sub test2() '10
Debug.Print Timer
Application.ScreenUpdating = False
Dim i, j
Sheets("Sheet2").Select
Range("A3").CurrentRegion.Offset(1).Clear
j = 4
Sheets("Sheet1").Select
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 2) = Worksheets("Sheet2").Range("B1") Then
Range("A" & i & ":" & "E"
& i).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A" & j).Select
ActiveSheet.Paste
Range("A" & j).NumberFormatLocal = "yyyy/m/d"
Range("E" & j).NumberFormatLocal = "#,##0"
Range("A" & i & ":" & "E" & i).Borders.LineStyle = xlContinuous
Sheets("Sheet1").Select
j = j + 1
End If
Next
Application.ScreenUpdating = True
Debug.Print Timer
End Sub
Application.ScreenUpdating = False
これが入っているかを確認して下さい。
問題点
・Sheetsの.Select
・RangeのSelect
・Rangeで("A" & j)
とにかく、この3点はダメです。
最期の
Rangeで("A" & j)
これは、測度も遅いのですが、何より見苦しいので止めましょう。
しかし、このようなVBAコードを教えている所があるらしいことを聞いています。
嘆かわしい事この上ない。
test3
Sub test3()
Debug.Print Timer
Application.ScreenUpdating = False
Dim i, j
Worksheets("Sheet2").Range("A3").CurrentRegion.Offset(1).Clear
j = 4
For i = 1 To Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
If Worksheets("Sheet1").Cells(i, 2) = Worksheets("Sheet2").Range("B1") Then
Worksheets("Sheet2").Cells(j, 1) = Worksheets("Sheet1").Cells(i, 1)
Worksheets("Sheet2").Cells(j, 2) = Worksheets("Sheet1").Cells(i, 2)
Worksheets("Sheet2").Cells(j, 3) = Worksheets("Sheet1").Cells(i, 3)
Worksheets("Sheet2").Cells(j, 4) = Worksheets("Sheet1").Cells(i, 4)
Worksheets("Sheet2").Cells(j, 5) = Worksheets("Sheet1").Cells(i, 5)
Worksheets("Sheet2").Cells(j, 1).NumberFormatLocal = "yyyy/m/d"
Worksheets("Sheet2").Cells(j, 5).NumberFormatLocal = "#,##0"
Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(j, 1), Worksheets("Sheet2").Cells(j, 5)).Borders.LineStyle = xlContinuous
j = j + 1
End If
Next
Application.ScreenUpdating = True
Debug.Print Timer
End Sub
test4
Sub test4() '3.01
Debug.Print Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i, j
Worksheets("Sheet2").Range("A3").CurrentRegion.Offset(1).Clear
j = 4
For i = 1 To Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
If Worksheets("Sheet1").Cells(i, 2) = Worksheets("Sheet2").Range("B1") Then
Worksheets("Sheet2").Cells(j, 1) = Worksheets("Sheet1").Cells(i, 1)
Worksheets("Sheet2").Cells(j, 2) = Worksheets("Sheet1").Cells(i, 2)
Worksheets("Sheet2").Cells(j, 3) = Worksheets("Sheet1").Cells(i, 3)
Worksheets("Sheet2").Cells(j, 4) = Worksheets("Sheet1").Cells(i, 4)
Worksheets("Sheet2").Cells(j, 5) = Worksheets("Sheet1").Cells(i, 5)
Worksheets("Sheet2").Cells(j, 1).NumberFormatLocal = "yyyy/m/d"
Worksheets("Sheet2").Cells(j, 5).NumberFormatLocal = "#,##0"
Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(j, 1), Worksheets("Sheet2").Cells(j, 5)).Borders.LineStyle = xlContinuous
j = j + 1
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print Timer
End Sub
(時間のかかる計算式を入れるのが面倒だったもので・・・)
test5
Sub test5() '3.01
Debug.Print Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i As Long
Dim j As Long
Worksheets("Sheet2").Range("A3").CurrentRegion.Offset(1).Clear
j = 4
For i = 1 To Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
If Worksheets("Sheet1").Cells(i, 2) = Worksheets("Sheet2").Range("B1") Then
Worksheets("Sheet2").Cells(j, 1) = Worksheets("Sheet1").Cells(i, 1)
Worksheets("Sheet2").Cells(j, 2) = Worksheets("Sheet1").Cells(i, 2)
Worksheets("Sheet2").Cells(j, 3) = Worksheets("Sheet1").Cells(i, 3)
Worksheets("Sheet2").Cells(j, 4) = Worksheets("Sheet1").Cells(i, 4)
Worksheets("Sheet2").Cells(j, 5) = Worksheets("Sheet1").Cells(i, 5)
Worksheets("Sheet2").Cells(j, 1).NumberFormatLocal = "yyyy/m/d"
Worksheets("Sheet2").Cells(j, 5).NumberFormatLocal = "#,##0"
Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(j, 1), Worksheets("Sheet2").Cells(j, 5)).Borders.LineStyle = xlContinuous
j = j + 1
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print Timer
End Sub
test6
Sub test6()
Debug.Print Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i As Long
Dim j As Long
Dim ws1 As Worksheet
Set ws1 = Worksheets("Sheet1")
j = 4
With Worksheets("Sheet2")
.Range("A3").CurrentRegion.Offset(1).Clear
For i = 1 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
If ws1.Cells(i, 2) = .Range("B1") Then
.Cells(j, 1) = ws1.Cells(i, 1)
.Cells(j, 2) = ws1.Cells(i, 2)
.Cells(j, 3) = ws1.Cells(i, 3)
.Cells(j, 4) = ws1.Cells(i, 4)
.Cells(j, 5) = ws1.Cells(i, 5)
.Cells(j, 1).NumberFormatLocal = "yyyy/m/d"
.Cells(j, 5).NumberFormatLocal = "#,##0"
.Range(.Cells(j, 1), .Cells(j, 5)).Borders.LineStyle = xlContinuous
j = j + 1
End If
Next
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print Timer
End Sub
test7
Sub test7()
Debug.Print Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i As Long
Dim j As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
ws2.Range("A3").CurrentRegion.Offset(1).Clear
j = 4
For i = 1 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
If ws1.Cells(i, 2) = ws2.Range("B1") Then
ws2.Cells(j, 1) = ws1.Cells(i, 1)
ws2.Cells(j, 2) = ws1.Cells(i, 2)
ws2.Cells(j, 3) = ws1.Cells(i, 3)
ws2.Cells(j, 4) = ws1.Cells(i, 4)
ws2.Cells(j, 5) = ws1.Cells(i, 5)
ws2.Cells(j, 1).NumberFormatLocal = "yyyy/m/d"
ws2.Cells(j, 5).NumberFormatLocal = "#,##0"
ws2.Range(ws2.Cells(j, 1), ws2.Cells(j, 5)).Borders.LineStyle = xlContinuous
j = j + 1
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print Timer
End Sub
test8
Sub test8()
Debug.Print Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i As Long
Dim j As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
ws2.Range("A3").CurrentRegion.Offset(1).Clear
j = 4
For i = 1 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
If ws1.Cells(i, 2) = ws2.Range("B1") Then
ws2.Cells(j, 1) = ws1.Cells(i, 1)
ws2.Cells(j, 2) = ws1.Cells(i, 2)
ws2.Cells(j, 3) = ws1.Cells(i, 3)
ws2.Cells(j, 4) = ws1.Cells(i, 4)
ws2.Cells(j, 5) = ws1.Cells(i, 5)
j = j + 1
End If
Next
ws2.Range(ws2.Cells(4, 1), ws2.Cells(j - 1, 1)).NumberFormatLocal = "yyyy/m/d"
ws2.Range(ws2.Cells(4, 5), ws2.Cells(j - 1, 5)).NumberFormatLocal = "#,##0"
ws2.Range(ws2.Cells(4, 1), ws2.Cells(j - 1, 5)).Borders.LineStyle = xlContinuous
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print Timer
End Sub
test9
Sub test9()
Debug.Print Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i As Long
Dim j As Long
Dim strFind As String
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
ws2.Range("A3").CurrentRegion.Offset(1).Clear
strFind = ws2.Range("B1")
j = 4
For i = 1 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
If ws1.Cells(i, 2) = strFind Then
ws2.Cells(j, 1) = ws1.Cells(i, 1)
ws2.Cells(j, 2) = ws1.Cells(i, 2)
ws2.Cells(j, 3) = ws1.Cells(i, 3)
ws2.Cells(j, 4) = ws1.Cells(i, 4)
ws2.Cells(j, 5) = ws1.Cells(i, 5)
j = j + 1
End If
Next
ws2.Range(ws2.Cells(4, 1), ws2.Cells(j - 1, 4)).NumberFormatLocal = "yyyy/m/d"
ws2.Range(ws2.Cells(4, 5), ws2.Cells(j - 1, 5)).NumberFormatLocal = "#,##0"
ws2.Range(ws2.Cells(4, 1), ws2.Cells(j - 1, 5)).Borders.LineStyle = xlContinuous
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print Timer
End Sub
test10
Sub test10()
Debug.Print Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i As Long
Dim j As Long
Dim strFind As String
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
ws2.Range("A3").CurrentRegion.Offset(1).Clear
strFind = ws2.Range("B1")
j = 4
For i = 1 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
If ws1.Cells(i, 2) = strFind Then
ws2.Range(ws2.Cells(j, 1), ws2.Cells(j, 5)).Value _
= ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, 5)).Value
j = j + 1
End If
Next
ws2.Range(ws2.Cells(4, 1), ws2.Cells(j - 1, 1)).NumberFormatLocal = "yyyy/m/d"
ws2.Range(ws2.Cells(4, 5), ws2.Cells(j - 1, 5)).NumberFormatLocal = "#,##0"
ws2.Range(ws2.Cells(4, 1), ws2.Cells(j - 1, 5)).Borders.LineStyle = xlContinuous
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print Timer
End Sub
test11
Sub test11()
Debug.Print Timer
' Application.ScreenUpdating = False
' Application.Calculation = xlCalculationManual
Dim i As Long
Dim j As Long
Dim strFind As String
Dim myAry1
Dim myAry2
Dim maxRow As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
maxRow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
myAry1 = ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxRow, 5))
ws2.Range("A3").CurrentRegion.Offset(1).Clear
strFind = ws2.Range("B1")
For i = LBound(myAry1, 1) To UBound(myAry1, 1)
If myAry1(i, 2) = strFind Then
If Not IsArray(myAry2) Then
ReDim myAry2(LBound(myAry1, 2) To UBound(myAry1, 2), 1 To 1)
Else
ReDim Preserve myAry2(LBound(myAry1, 2) To UBound(myAry1, 2), 1 To UBound(myAry2, 2) + 1)
End If
For j = LBound(myAry1, 2) To UBound(myAry1, 2)
myAry2(j, UBound(myAry2, 2)) = myAry1(i, j)
Next
End If
Next
j = UBound(myAry2, 2) + 3
ws2.Range(ws2.Cells(4, 1), ws2.Cells(j, 5)).Value = WorksheetFunction.Transpose(myAry2)
ws2.Range(ws2.Cells(4, 1), ws2.Cells(j, 1)).NumberFormatLocal = "yyyy/m/d"
ws2.Range(ws2.Cells(4, 5), ws2.Cells(j, 5)).NumberFormatLocal = "#,##0"
ws2.Range(ws2.Cells(4, 1), ws2.Cells(j, 5)).Borders.LineStyle = xlContinuous
' Application.Calculation = xlCalculationAutomatic
' Application.ScreenUpdating = True
Debug.Print Timer
End Sub
Application.Calculation = xlCalculationManual
総括
テスト項番 | 所要時間 | 高速化・速度対策内容 |
test1 | 46秒 | シートやセルをSelectしている最悪のVBA |
test2 | 10秒 | Application.ScreenUpdating =False を追加 |
test3 | 3.03秒 | シートやセルをSelectを止める |
test4 | 3.01秒 | Application.Calculation = xlCalculationManual を追加 |
test5 | 3.01秒 | 変数の型宣言を追加 |
test6 | 2.81秒 | WithステートメントでWorksheetsを指定 |
test7 | 2.65秒 | すべてオブジェクト変数に変更 |
test8 | 0.53秒 | セルの書式設定を一括で設定 |
test9 | 0.35秒 | 何度も使うセル値(検索値)を変数に入れる |
test10 | 0.22秒 | 複数セル値を1行分まとめて入れる |
test11 | 0.08秒 | 配列の使用 |
上から順にVBAコードを確認してみて下さい。
参考
速度比較決定版【Range,Cells,Do,For,For Each】
エクセルVBAのパフォーマンス・処理速度に関するレポート
Findメソッドを私が使わない理由
記述による処理速度の違い
追記
上記の対策をしてもまだ遅い、もしくはもっと速くしたい、という事があれば、
以下の技術が適用できないか検討してみて下さい。
大量データにおける処理方法の速度王決定戦
遅い文字列結合を最速処理する方法について
同じテーマ「マクロVBA技術解説」の記事
速度比較決定版【Range,Cells,Do,For,ForEach】
エクセルVBAのパフォーマンス・処理速度に関するレポート
VBAのFindメソッドの使い方には注意が必要です
マクロVBAの高速化・速度対策の具体的手順と検証
動的2次元配列の次元を入れ替えてシートへ出力(Transpose)
大量データで処理時間がかかる関数の対処方法(SumIf)
大量データにおける処理方法の速度王決定戦
遅い文字列結合を最速処理する方法について
大量VlookupをVBAで高速に処理する方法について
Withステートメントの実行速度と注意点
IfステートメントとIIF関数とMax関数の速度比較
新着記事NEW ・・・新着記事一覧を見る
新旧マスタの差異比較|Power Query(M言語)入門(2023-02-28)
有効な最新単価の取得|Power Query(M言語)入門(2023-02-26)
有効な最新単価の取得|Power Query(M言語)入門(2023-02-21)
グルーブ内の最小・最大|Power Query(M言語)入門(2023-02-17)
2つのテーブルのマージ|Power Query(M言語)入門(2023-02-15)
「売上」が数値の行のみ取り込む|Power Query(M言語)入門(2023-02-13)
A列のヘッダー名を変更する|Power Query(M言語)入門(2023-02-11)
CSVのA列が日付の行だけを取り込む|Power Query(M言語)入門(2023-02-10)
列数不定のCSVの取り込み|Power Query(M言語)入門(2023-02-09)
別ブックの最終シートの取り込み|Power Query(M言語)入門(2023-02-08)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.繰り返し処理(For Next)|VBA入門
5.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
6.マクロって何?VBAって何?|VBA入門
7.並べ替え(Sort)|VBA入門
8.Excelショートカットキー一覧|Excelリファレンス
9.エクセルVBAでのシート指定方法|VBA技術解説
10.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
- ホーム
- マクロVBA応用編
- マクロVBA技術解説
- マクロVBAの高速化・速度対策の具体的手順と検証
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。