マクロ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 ・・・新着記事一覧を見る
TRIMRANGE関数(セル範囲をトリム:端の空白セルを除外)|エクセル入門(2024-08-30)
正規表現関数(REGEXTEST,REGEXREPLACE,REGEXEXTRACT)|エクセル入門(2024-07-02)
エクセルが起動しない、Excelが立ち上がらない|エクセル雑感(2024-04-11)
ブール型(Boolean)のis変数・フラグについて|VBA技術解説(2024-04-05)
テキストの内容によって図形を削除する|VBA技術解説(2024-04-02)
ExcelマクロVBA入門目次|エクセルの神髄(2024-03-20)
VBA10大躓きポイント(初心者が躓きやすいポイント)|VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成|ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。|エクセル雑感(2024-02-17)
初級脱出10問パック|VBA練習問題(2024-01-24)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得(End,Rows.Count)|VBA入門
2.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
3.繰り返し処理(For Next)|VBA入門
4.変数宣言のDimとデータ型|VBA入門
5.RangeとCellsの使い方|VBA入門
6.ブックを閉じる・保存(Close,Save,SaveAs)|VBA入門
7.メッセージボックス(MsgBox関数)|VBA入門
8.セルのクリア(Clear,ClearContents)|VBA入門
9.ブック・シートの選択(Select,Activate)|VBA入門
10.条件分岐(Select Case)|VBA入門
- ホーム
- マクロVBA応用編
- マクロVBA技術解説
- マクロVBAの高速化・速度対策の具体的手順と検証
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。