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

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

ただいまの
回答率

90.33%

  • VBA

    1906questions

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

VBA高速化について

解決済

回答 2

投稿

  • 評価
  • クリップ 1
  • VIEW 2,200

pgnoobdesu

score 18

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

Public Sub measure()

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual


    Dim i As Integer

    Dim tmp As Workbook

    Dim a, b As Double

    a = CDbl(Timer)

    Dim matchRow As Long
    Dim targetValue As String

    Dim searchArray(2) As Integer

    searchArray(0) = 111
    searchArray(1) = 222
    searchArray(2) = 333

    Dim searchTmp As Variant
    Dim lastRow As Long

    On Error Resume Next

    For i = 1 To 20

        Set tmp = Workbooks.Open("C:\test\" & i & ".xlsx", ReadOnly:=True)

        With tmp.Sheets("1")

            For Each searchTmp In searchArray

                matchRow = WorksheetFunction.Match(searchTmp, .Range("test[id]"), 0)

                If .Cells(matchRow + 1, .Range("test[id]").Column).Value = searchTmp Then

                    targetValue = .Cells(matchRow + 1, .Range("test[id]").Column + 1).Value

                    With ThisWorkbook.Sheets("sheet5")

                        matchRow = WorksheetFunction.Match(searchTmp, .Range("collect[id]"), 0)

                        If .Cells(matchRow + 1, .Range("collect[id]").Column).Value <> searchTmp Then

                            '新規追加
                            lastRow = .Cells(.Rows.Count, .Range("collect[id]").Column).End(xlUp).Row

                            '追加行確定
                            If .Cells(lastRow, .Range("collect[id]").Column).Value <> "" Then

                                lastRow = lastRow + 1

                            End If

                            .Cells(lastRow, .Range("collect[id]").Column).Value = searchTmp
                            .Cells(lastRow, .Range("collect[id]").Column + 1).Value = targetValue

                        Else

                            '変更
                            .Cells(matchRow + 1, .Range("collect[id]").Column + 1).Value = targetValue

                        End If

                    End With

                End If

            Next


        End With


        tmp.Close

    Next

    b = CDbl(Timer)

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic

    Debug.Print b - a

End Sub


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

よろしくお願いします。

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

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

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

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 2

checkベストアンサー

0

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

On Error Resume Next


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

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

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

' バグ防止のため変数宣言を強制
Option Explicit

' テーブルデータ最新化
Public Sub measure()

    ' 変数宣言
    ' 【コメント】:Integer型は32767までしか入らないので桁あふれリスクがあります。また、Longの方が性能が良いです。
    Dim i As Long
    ' 【コメント】:変数名は型が推測できるものが良いです。tmpやbufなどの変数名はなるべく避けるべきです
    Dim book As Workbook
    ' 【コメント】:Dim a, b As Doubleという宣言の場合、aはVariant型になってしまっています。Variant型はどんな型でも受け付ける万能型なのでバグの温床となります。使用は最小限にしましょう
    Dim startTime As Single
    Dim matchRow As Long
    Dim targetText As String
    Dim searchArray As Collection
    Dim searchText As Variant
    Dim lastRow As Long
    Dim fso As FileSystemObject
    Dim myFile As File

    ' 定数宣言
    Const BOOK_DIR As String = "C:\test"

    ' 処理開始時刻を取得
    startTime = Timer

    ' 画面描画などを抑止
    ApplicationSetting False

    ' 検索対象文字列リストを取得
    ' 【コメント】:検索対象文字列リストは比較的変更が発生しやすいプロシージャだと推測しましたので、プロシージャ分割を実施しました
    Set searchArray = GetSearchArray

    ' オブジェクト取得
    Set fso = CreateObject("Scripting.FileSystemObject")

    ' エラー制御はコーダーの意図しないエラーによる想定外挙動を全て把握するためにもなるべく小さい範囲に留めたエラー制御を実施すべきです
    ' On Error Resume Next


    ' 検索対象ディレクトリの全ファイルを走査
    For Each myFile In fso.GetFolder(BOOK_DIR).Files

        ' 処理対象のブックのみ処理
        If IsValidBookName(myFile.Name) Then

            ' エラー制御開始
            On Error Resume Next

            ' ブックを開く
            Set book = Workbooks.Open(myFile.Path, ReadOnly:=True)

            ' エラー制御終了
            On Error GoTo 0

            ' ブックが開けなかった場合はログ出力
            If book Is Nothing Then
                Debug.Print myFile.Path & "を開けませんでした"
            Else

                ' 1シート目を処理
                With book.Worksheets(1)

                    ' 全検索対象文字列を走査
                    For Each searchText In searchArray

                        ' 検索結果初期化
                        matchRow = 0

                        ' エラー制御開始
                        On Error Resume Next

                        ' 検索対象文字列を検索
                        matchRow = Application.WorksheetFunction.Match(searchText, .Range("test[id]"), 0)

                        ' エラー制御終了
                        On Error GoTo 0

                        ' 検索結果が存在する場合
                        If matchRow <> 0 Then

                            ' 取得対象文字列を取得
                            targetText = .Cells(matchRow + 1, .Range("test[id]").Column + 1).Text

                            With ThisWorkbook.Worksheets("sheet5")

                                ' 検索結果初期化
                                matchRow = 0

                                ' エラー制御開始
                                On Error Resume Next

                                ' 検索対象文字列を検索
                                matchRow = WorksheetFunction.Match(searchText, .Range("collect[id]"), 0)

                                ' エラー制御終了
                                On Error GoTo 0

                                ' 検索結果が存在する場合
                                If matchRow = 0 Then

                                    ' 追加行取得
                                    lastRow = .Cells(.Rows.Count, .Range("collect[id]").Column).End(xlUp).Row + 1

                                    ' 追加行に値設定
                                    .Cells(lastRow, .Range("collect[id]").Column).Value = searchText
                                    .Cells(lastRow, .Range("collect[id]").Column + 1).Value = targetText

                                Else

                                    ' 対象行を更新
                                    .Cells(matchRow + 1, .Range("collect[id]").Column + 1).Value = targetText

                                End If

                            End With

                        End If

                    Next

                End With

                ' ブックを閉じる(保存しない)
                book.Close False

            End If

        End If

    Next

    ' 画面描画などを再開
    ApplicationSetting True

    ' 処理に要した時間を出力
    Debug.Print "処理に要した時間:" & Timer - startTime & "秒"

End Sub

' 処理対象のファイルかどうかを判定
Private Function IsValidBookName(ByRef pFileName As String) As Boolean

    ' 変数宣言
    Dim re As RegExp

    ' オブジェクト初期化
    Set re = CreateObject("VBScript.RegExp")

    ' 正規表現パターンを設定
    With re
        .Global = True
        .IgnoreCase = False
        .Pattern = "^[0-9]+\.(xls|xlsx|xlsm)$"
    End With

    ' 引数のファイル名がExcelファイルか判定
    If re.Test(pFileName) Then
        IsValidBookName = True
    Else
        IsValidBookName = False
    End If

End Function


' 検索対象文字列リストの取得
Private Function GetSearchArray() As Collection

    ' 変数宣言
    Dim myCollection As Collection

    ' オブジェクトを初期化
    Set myCollection = New Collection

    ' 検索対象を設定
    With myCollection
        .Add 111
        .Add 222
        .Add 333
    End With

    ' 結果返却
    Set GetSearchArray = myCollection

End Function

' Excelアプリケーションの設定(引数がTrueの時に有効とする)
Private Sub ApplicationSetting(ByRef pEnabled As Boolean)

    With Application
        ' 画面描画の設定
        .ScreenUpdating = pEnabled
        ' 警告・確認ダイアログの設定
        .DisplayAlerts = pEnabled
        ' イベントのコントール設定
        .EnableEvents = pEnabled
        ' 再計算の実施有無設定
        .Calculation = IIf(pEnabled, xlCalculationAutomatic, xlCalculationManual)
    End With

End Sub

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2017/09/16 15:29

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

    キャンセル

  • 2017/09/16 15:30

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

    キャンセル

0

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

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

  Dim i As Integer
  Dim tmp As Workbook
  Dim a, b As Double

  a = CDbl(Timer)

  Dim searchArray(2) As Integer
  searchArray(0) = 111
  searchArray(1) = 222
  searchArray(2) = 333

  Dim searchTmp As Variant
  Dim targetSheet As WorkSheet
  Dim targetRange As Range
  Dim values As Variant
  Dim numberOfRows As Long, numberOfColumns As Long
  Dim j As Long

  Dim resultSheet As WorkSheet
  Dim resultRange As Range
  Dim results As Variant
  Dim resultRows As Long, resultColumns As Long
  Dim indices(2) As Long
  Dim indexFound As Long
  Dim k As Integer

  On Error Resume Next

  Set resultSheet = ThisWorkbook.Sheets("sheet5")
  Set resultRange = resultSheet.Range("collect[id]")
  resultRows = resultRange.Rows
  resultColumns = resultRange.Columns + 1
  resultRange.resize(, resultColumns)
  results = resultRange

  For k = 0 To 2
    indices(k) = -1
    searchTmp = searchArray(k)
    For j = 1 To resultRows
      If results(j, 1) == searchTmp Then
        indices(k) = j
      End If
    Next j
  Next k

  For i = 1 To 20
    Set tmp = Workbooks.Open("C:\test\" & i & ".xlsx", ReadOnly:=True)
    Set targetSheet = tmp.Sheets(1)
    Set targetRange = targetSheet.Range("test[id]")
    numberOfRows = targetRange.Rows
    numberOfColumns = targetRange.Columns + 1
    targetRange.Resize(, targetRange.Columns)
    values = targetRange
    For k = 0 to 2
      searchTmp = searchArray(k)
      For j = 1 To numberOfRows
        If values(j, 1) == searchTmp Then
          indexFound = indices(k)
          If indexFound < 0 Then
            '新規追加
            resultRange = results
            resultRows = resultRange.Rows + 1
            resultRange.resize(resultRows)
            results = resultRange
            indexFound = resultRows
            indices(k) = indexFound
          End If
          results(indexFound, 2) = values(j, 2)
        End If
    Next k
    resultRange = results

    tmp.Close
  Next i

  b = CDbl(Timer)

  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic

  Debug.Print b - a
End Sub

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2017/09/16 14:51

    >With を使わず、明示的なオブジェクトを使う
    Withブロックを使用しない場合、毎回メモリから親オブジェクトを見つけたのちのその配下のプロパティを探すという処理が走るためにメモリから読みだす速度が低下します。
    よってWithブロックは積極的に使用すべきです。

    >特定の値を探す読み込み用シートも、書き込むシートも一旦中身をメモリ上にあげて処理する
    ThisWorkbookはそもそもメモリ上のオブジェクトなのでこれを再度オブジェクトに格納しても意味がありません。スタック領域の二重使用となるだけです。

    キャンセル

  • 2017/09/16 14:55

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

    キャンセル

  • 2017/09/16 14:58

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

    キャンセル

  • 2017/09/16 15:08

    >Set TargetRange = TargetSheet.Range() とやるほうがトータルでは速かったんじゃないか
    その場合はTargetRangeをWithで囲うべきなのではないでしょうか。Withブロックを使うことでメモリのポインタを記憶しておけるのでメモリ読み出しが速くなると認識していましたが、もう一度確認してみます。これは間違っていたら大変に申し訳ないです。

    >今回のように二重に With ブロックがあったりすると不利かな
    おっしゃる通りだと思います。Withブロックの性質をしっかり理解しているコーダーでないと混乱を招く要因だと思います。二重のWithは使わないべきは同意です。

    >Sheet に対して Range 関数や Cells 関数を使って、逐一セルの値を読んだり書いたりするのではなく、一旦 2 次元配列に格納したうえで読み書きし、シートに書き戻す必要があっても一度で済ます
    これも同意です。VBAの高速化裏テクの王道ですよね。私もセルを走査する系の処理の際はなるべく一度Variant配列に格納してから処理を実行しています。
    今回の場合ですと、一般的にはFindメソッドを使う場面でWorksheetFunctionを使用されていたので、(確かにFiindよりWorksheetFunction.Matchの方が速い)上記裏テクをうまく導入することができず、私の回答も裏テクなしの回答となっています。

    キャンセル

  • 2017/09/16 15:27

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

    キャンセル

  • 2017/09/16 15:32

    ちゃんと動かないし、速くもないし、ダメですな。

    どうにか Excel に触れる機会があればちゃんと検証したいところです。

    キャンセル

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

  • ただいまの回答率 90.33%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

同じタグがついた質問を見る

  • VBA

    1906questions

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