質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.50%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Q&A

解決済

2回答

1291閲覧

VBA高速化について

pgnoobdesu

総合スコア35

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

0グッド

1クリップ

投稿2017/09/16 03:13

20個のエクセルファイルを読み込み、特定のシートにあるテーブルから特定の値を探し出し、その右横にあるセルの値を取り出します。
集計用のエクセルのテーブルでも、同じ特定の値をテーブルから探し出し、もしその値が見つかれば先ほど取り出した値に変更、なければテーブルの一番下の行に追加、というコードを書いたのですが、このコードで他に高速化できる部分はありますでしょうか?

vba

1Public Sub measure() 2 3 Application.ScreenUpdating = False 4 Application.EnableEvents = False 5 Application.Calculation = xlCalculationManual 6 7 8 Dim i As Integer 9 10 Dim tmp As Workbook 11 12 Dim a, b As Double 13 14 a = CDbl(Timer) 15 16 Dim matchRow As Long 17 Dim targetValue As String 18 19 Dim searchArray(2) As Integer 20 21 searchArray(0) = 111 22 searchArray(1) = 222 23 searchArray(2) = 333 24 25 Dim searchTmp As Variant 26 Dim lastRow As Long 27 28 On Error Resume Next 29 30 For i = 1 To 20 31 32 Set tmp = Workbooks.Open("C:\test\" & i & ".xlsx", ReadOnly:=True) 33 34 With tmp.Sheets("1") 35 36 For Each searchTmp In searchArray 37 38 matchRow = WorksheetFunction.Match(searchTmp, .Range("test[id]"), 0) 39 40 If .Cells(matchRow + 1, .Range("test[id]").Column).Value = searchTmp Then 41 42 targetValue = .Cells(matchRow + 1, .Range("test[id]").Column + 1).Value 43 44 With ThisWorkbook.Sheets("sheet5") 45 46 matchRow = WorksheetFunction.Match(searchTmp, .Range("collect[id]"), 0) 47 48 If .Cells(matchRow + 1, .Range("collect[id]").Column).Value <> searchTmp Then 49 50 '新規追加 51 lastRow = .Cells(.Rows.Count, .Range("collect[id]").Column).End(xlUp).Row 52 53 '追加行確定 54 If .Cells(lastRow, .Range("collect[id]").Column).Value <> "" Then 55 56 lastRow = lastRow + 1 57 58 End If 59 60 .Cells(lastRow, .Range("collect[id]").Column).Value = searchTmp 61 .Cells(lastRow, .Range("collect[id]").Column + 1).Value = targetValue 62 63 Else 64 65 '変更 66 .Cells(matchRow + 1, .Range("collect[id]").Column + 1).Value = targetValue 67 68 End If 69 70 End With 71 72 End If 73 74 Next 75 76 77 End With 78 79 80 tmp.Close 81 82 Next 83 84 b = CDbl(Timer) 85 86 Application.ScreenUpdating = True 87 Application.EnableEvents = True 88 Application.Calculation = xlCalculationAutomatic 89 90 Debug.Print b - a 91 92End Sub

私の環境ですと、約5.2秒
エクセルのインスタンスを生成してブックを開く方法に変えた場合は約4.5秒でした。
別に遅いわけではないのですが、まだVBAを始めたばかりなので、
For文の中の処理をもっと高速化できる方法あるのかなーと思って投稿させて頂きました。

よろしくお願いします。

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

guest

回答2

0

手元に Excel がなくて未検証ですが、こんなコードはどうでしょうか。
考えたことは

  • 特定の値を探す読み込み用シートも、書き込むシートも一旦中身をメモリ上にあげて処理する
  • 書き込みシートの searchArray(k) がある行数は事前に求めておけるので indices(k) に記録しておく
  • With を使わず、明示的なオブジェクトを使う
  • 同じ表現を何度も使わず、適切な変数を用意する

vba

1Public Sub measure() 2 Application.ScreenUpdating = False 3 Application.EnableEvents = False 4 Application.Calculation = xlCalculationManual 5 6 Dim i As Integer 7 Dim tmp As Workbook 8 Dim a, b As Double 9 10 a = CDbl(Timer) 11 12 Dim searchArray(2) As Integer 13 searchArray(0) = 111 14 searchArray(1) = 222 15 searchArray(2) = 333 16 17 Dim searchTmp As Variant 18 Dim targetSheet As WorkSheet 19 Dim targetRange As Range 20 Dim values As Variant 21 Dim numberOfRows As Long, numberOfColumns As Long 22 Dim j As Long 23 24 Dim resultSheet As WorkSheet 25 Dim resultRange As Range 26 Dim results As Variant 27 Dim resultRows As Long, resultColumns As Long 28 Dim indices(2) As Long 29 Dim indexFound As Long 30 Dim k As Integer 31 32 On Error Resume Next 33 34 Set resultSheet = ThisWorkbook.Sheets("sheet5") 35 Set resultRange = resultSheet.Range("collect[id]") 36 resultRows = resultRange.Rows 37 resultColumns = resultRange.Columns + 1 38 resultRange.resize(, resultColumns) 39 results = resultRange 40 41 For k = 0 To 2 42 indices(k) = -1 43 searchTmp = searchArray(k) 44 For j = 1 To resultRows 45 If results(j, 1) == searchTmp Then 46 indices(k) = j 47 End If 48 Next j 49 Next k 50 51 For i = 1 To 20 52 Set tmp = Workbooks.Open("C:\test\" & i & ".xlsx", ReadOnly:=True) 53 Set targetSheet = tmp.Sheets(1) 54 Set targetRange = targetSheet.Range("test[id]") 55 numberOfRows = targetRange.Rows 56 numberOfColumns = targetRange.Columns + 1 57 targetRange.Resize(, targetRange.Columns) 58 values = targetRange 59 For k = 0 to 2 60 searchTmp = searchArray(k) 61 For j = 1 To numberOfRows 62 If values(j, 1) == searchTmp Then 63 indexFound = indices(k) 64 If indexFound < 0 Then 65 '新規追加 66 resultRange = results 67 resultRows = resultRange.Rows + 1 68 resultRange.resize(resultRows) 69 results = resultRange 70 indexFound = resultRows 71 indices(k) = indexFound 72 End If 73 results(indexFound, 2) = values(j, 2) 74 End If 75 Next k 76 resultRange = results 77 78 tmp.Close 79 Next i 80 81 b = CDbl(Timer) 82 83 Application.ScreenUpdating = True 84 Application.EnableEvents = True 85 Application.Calculation = xlCalculationAutomatic 86 87 Debug.Print b - a 88End Sub 89

投稿2017/09/16 05:40

編集2017/09/16 05:42
unau

総合スコア2468

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

yamashita_yuich

2017/09/16 05:51

>With を使わず、明示的なオブジェクトを使う Withブロックを使用しない場合、毎回メモリから親オブジェクトを見つけたのちのその配下のプロパティを探すという処理が走るためにメモリから読みだす速度が低下します。 よってWithブロックは積極的に使用すべきです。 >特定の値を探す読み込み用シートも、書き込むシートも一旦中身をメモリ上にあげて処理する ThisWorkbookはそもそもメモリ上のオブジェクトなのでこれを再度オブジェクトに格納しても意味がありません。スタック領域の二重使用となるだけです。
unau

2017/09/16 05:55

With ブロックを使わず、というのは、With TargetSheet 〜 End With の中で .Range() をやるよりも、確か Set TargetRange = TargetSheet.Range() とやるほうがトータルでは速かったんじゃないか、ということです。あと、可読性やメンテナンス性で、どちらかが上か、というのもありますが、今回のように二重に With ブロックがあったりすると不利かな、と。
unau

2017/09/16 05:58

「特定の値を探す読み込み用シートも、書き込むシートも一旦中身をメモリ上にあげて処理する」、これは表現が適切ではありませんでした。Sheet に対して Range 関数や Cells 関数を使って、逐一セルの値を読んだり書いたりするのではなく、一旦 2 次元配列に格納したうえで読み書きし、シートに書き戻す必要があっても一度で済ます、という意味です。
yamashita_yuich

2017/09/16 06:08

>Set TargetRange = TargetSheet.Range() とやるほうがトータルでは速かったんじゃないか その場合はTargetRangeをWithで囲うべきなのではないでしょうか。Withブロックを使うことでメモリのポインタを記憶しておけるのでメモリ読み出しが速くなると認識していましたが、もう一度確認してみます。これは間違っていたら大変に申し訳ないです。 >今回のように二重に With ブロックがあったりすると不利かな おっしゃる通りだと思います。Withブロックの性質をしっかり理解しているコーダーでないと混乱を招く要因だと思います。二重のWithは使わないべきは同意です。 >Sheet に対して Range 関数や Cells 関数を使って、逐一セルの値を読んだり書いたりするのではなく、一旦 2 次元配列に格納したうえで読み書きし、シートに書き戻す必要があっても一度で済ます これも同意です。VBAの高速化裏テクの王道ですよね。私もセルを走査する系の処理の際はなるべく一度Variant配列に格納してから処理を実行しています。 今回の場合ですと、一般的にはFindメソッドを使う場面でWorksheetFunctionを使用されていたので、(確かにFiindよりWorksheetFunction.Matchの方が速い)上記裏テクをうまく導入することができず、私の回答も裏テクなしの回答となっています。
pgnoobdesu

2017/09/16 06:27

unauさんのコードで実験してみたところ、何もデータが集計されなかったのですが、時間的には5.6秒でした(resizeメソッドの使い方が間違ってたりやif文のイコールが多かったりしたので直した上で実行させて頂きました) 二重withブロックにならないように注意してプログラムします。あとセル走査系の処理は配列に入れてから処理するようにします。ありがとうございました。
unau

2017/09/16 06:32

ちゃんと動かないし、速くもないし、ダメですな。 どうにか Excel に触れる機会があればちゃんと検証したいところです。
guest

0

ベストアンサー

処理速度の面では良いと思いますが、プログラムの堅牢さという面では指摘すべき点がありましたので、提示頂いたソースを基に修正してみました。
特に、

VBA

1On Error Resume Next

を広い範囲で使用することはよろしくありません。
想定外のエラーが発生しても誰も気づけずに正しい処理がされていない可能性があるからです。

以下修正したコードです。
完璧ではないかもしれませんがそれなりに堅牢に書けていると思います。

※下記コードを実施するために、
Microsoft Scripting Runtime
Microsoft VBScript Regular Expressions 5.5
を参照設定に追加して下さい。
追加方法:VBE(VBAを書くエディタ)の上のメニューにてツール(T)→参照設定(R)

VBA

1' バグ防止のため変数宣言を強制 2Option Explicit 3 4' テーブルデータ最新化 5Public Sub measure() 6 7 ' 変数宣言 8 ' 【コメント】:Integer型は32767までしか入らないので桁あふれリスクがあります。また、Longの方が性能が良いです。 9 Dim i As Long 10 ' 【コメント】:変数名は型が推測できるものが良いです。tmpやbufなどの変数名はなるべく避けるべきです 11 Dim book As Workbook 12 ' 【コメント】:Dim a, b As Doubleという宣言の場合、aはVariant型になってしまっています。Variant型はどんな型でも受け付ける万能型なのでバグの温床となります。使用は最小限にしましょう 13 Dim startTime As Single 14 Dim matchRow As Long 15 Dim targetText As String 16 Dim searchArray As Collection 17 Dim searchText As Variant 18 Dim lastRow As Long 19 Dim fso As FileSystemObject 20 Dim myFile As File 21 22 ' 定数宣言 23 Const BOOK_DIR As String = "C:\test" 24 25 ' 処理開始時刻を取得 26 startTime = Timer 27 28 ' 画面描画などを抑止 29 ApplicationSetting False 30 31 ' 検索対象文字列リストを取得 32 ' 【コメント】:検索対象文字列リストは比較的変更が発生しやすいプロシージャだと推測しましたので、プロシージャ分割を実施しました 33 Set searchArray = GetSearchArray 34 35 ' オブジェクト取得 36 Set fso = CreateObject("Scripting.FileSystemObject") 37 38 ' エラー制御はコーダーの意図しないエラーによる想定外挙動を全て把握するためにもなるべく小さい範囲に留めたエラー制御を実施すべきです 39 ' On Error Resume Next 40 41 42 ' 検索対象ディレクトリの全ファイルを走査 43 For Each myFile In fso.GetFolder(BOOK_DIR).Files 44 45 ' 処理対象のブックのみ処理 46 If IsValidBookName(myFile.Name) Then 47 48 ' エラー制御開始 49 On Error Resume Next 50 51 ' ブックを開く 52 Set book = Workbooks.Open(myFile.Path, ReadOnly:=True) 53 54 ' エラー制御終了 55 On Error GoTo 0 56 57 ' ブックが開けなかった場合はログ出力 58 If book Is Nothing Then 59 Debug.Print myFile.Path & "を開けませんでした" 60 Else 61 62 ' 1シート目を処理 63 With book.Worksheets(1) 64 65 ' 全検索対象文字列を走査 66 For Each searchText In searchArray 67 68 ' 検索結果初期化 69 matchRow = 0 70 71 ' エラー制御開始 72 On Error Resume Next 73 74 ' 検索対象文字列を検索 75 matchRow = Application.WorksheetFunction.Match(searchText, .Range("test[id]"), 0) 76 77 ' エラー制御終了 78 On Error GoTo 0 79 80 ' 検索結果が存在する場合 81 If matchRow <> 0 Then 82 83 ' 取得対象文字列を取得 84 targetText = .Cells(matchRow + 1, .Range("test[id]").Column + 1).Text 85 86 With ThisWorkbook.Worksheets("sheet5") 87 88 ' 検索結果初期化 89 matchRow = 0 90 91 ' エラー制御開始 92 On Error Resume Next 93 94 ' 検索対象文字列を検索 95 matchRow = WorksheetFunction.Match(searchText, .Range("collect[id]"), 0) 96 97 ' エラー制御終了 98 On Error GoTo 0 99 100 ' 検索結果が存在する場合 101 If matchRow = 0 Then 102 103 ' 追加行取得 104 lastRow = .Cells(.Rows.Count, .Range("collect[id]").Column).End(xlUp).Row + 1 105 106 ' 追加行に値設定 107 .Cells(lastRow, .Range("collect[id]").Column).Value = searchText 108 .Cells(lastRow, .Range("collect[id]").Column + 1).Value = targetText 109 110 Else 111 112 ' 対象行を更新 113 .Cells(matchRow + 1, .Range("collect[id]").Column + 1).Value = targetText 114 115 End If 116 117 End With 118 119 End If 120 121 Next 122 123 End With 124 125 ' ブックを閉じる(保存しない) 126 book.Close False 127 128 End If 129 130 End If 131 132 Next 133 134 ' 画面描画などを再開 135 ApplicationSetting True 136 137 ' 処理に要した時間を出力 138 Debug.Print "処理に要した時間:" & Timer - startTime & "秒" 139 140End Sub 141 142' 処理対象のファイルかどうかを判定 143Private Function IsValidBookName(ByRef pFileName As String) As Boolean 144 145 ' 変数宣言 146 Dim re As RegExp 147 148 ' オブジェクト初期化 149 Set re = CreateObject("VBScript.RegExp") 150 151 ' 正規表現パターンを設定 152 With re 153 .Global = True 154 .IgnoreCase = False 155 .Pattern = "^[0-9]+\.(xls|xlsx|xlsm)$" 156 End With 157 158 ' 引数のファイル名がExcelファイルか判定 159 If re.Test(pFileName) Then 160 IsValidBookName = True 161 Else 162 IsValidBookName = False 163 End If 164 165End Function 166 167 168' 検索対象文字列リストの取得 169Private Function GetSearchArray() As Collection 170 171 ' 変数宣言 172 Dim myCollection As Collection 173 174 ' オブジェクトを初期化 175 Set myCollection = New Collection 176 177 ' 検索対象を設定 178 With myCollection 179 .Add 111 180 .Add 222 181 .Add 333 182 End With 183 184 ' 結果返却 185 Set GetSearchArray = myCollection 186 187End Function 188 189' Excelアプリケーションの設定(引数がTrueの時に有効とする) 190Private Sub ApplicationSetting(ByRef pEnabled As Boolean) 191 192 With Application 193 ' 画面描画の設定 194 .ScreenUpdating = pEnabled 195 ' 警告・確認ダイアログの設定 196 .DisplayAlerts = pEnabled 197 ' イベントのコントール設定 198 .EnableEvents = pEnabled 199 ' 再計算の実施有無設定 200 .Calculation = IIf(pEnabled, xlCalculationAutomatic, xlCalculationManual) 201 End With 202 203End Sub 204

投稿2017/09/16 05:34

編集2017/09/16 05:41
yamashita_yuich

総合スコア316

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

pgnoobdesu

2017/09/16 06:29

Dim a, b As Double このaがvariant型になるのは知りませんでした。ありがとうございます。 提示して頂いたコードもすごく読みやすく勉強になりました!
pgnoobdesu

2017/09/16 06:30

迷ったのですがこちらの方をBAにさせていただきます。
guest

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.50%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問