VBAファイル操作の高速化

Question

あるディレクトリにあるすべてのファイルを開いて必要個所をコピーし、一つのブックにまとめる作業をしています。
しかしこの作業が非常に時間がかかります。フォルダ内50程度のファイルでも１～２分。最終的に1000ファイル位を扱うことを考えると、少しでも高速化したいところです。どなたかお知恵を拝借できませんか。

大変失礼しました。
Application.ScreenUpdating = False
Application.ScreenUpdating = True
のセットが抜けておりました。描写非表示でなおかつ高速化の手順があればご教示願います。

Sub 各ブック必要個所集合()
    Application.DisplayAlerts = False
    
    Dim dlg As FileDialog
    Dim fold_path As String, i As String

     Set dlg = Application.FileDialog(msoFileDialogFolderPicker)

    ' キャンセルクリック処理
     If dlg.Show = False Then Exit Sub

    ' フォルダフルパスを変数格納
     fold_path = dlg.SelectedItems(1)

    Set mb = ThisWorkbook
    myfdr = ThisWorkbook.Path
    fname = Dir(fold_path & "*.xls")
    Do Until fname = Empty
    If fname <> mb.Name Then
    Application.EnableEvents = False
    Set wb = Workbooks.Open(fold_path & "\" & fname)
    Application.EnableEvents = True
    
    Sheets("あああああ").Visible = True

    Worksheets("あああああ").Select
    Range("e2:e633").Copy
    mb.Activate
    Worksheets("いいいいい").Select
    Cells(1, 10000).End(xlToLeft).Offset(0, 1).Select
    ActiveCell.Value = x & wb.Name
    ActiveCell.Offset(1, 0).PasteSpecial xlPasteAll
    wb.Close
    End If
    fname = Dir
    Loop
    
End Sub

Answer 1

Option Explicit
Sub 各ブック必要個所集合()
    Dim dlg As FileDialog
    Dim fold_path As String
    Dim Sh As Worksheet
    Dim Col As Long
    Dim fname As String
    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    If dlg.Show = False Then Exit Sub       ' キャンセルクリック処理
    fold_path = dlg.SelectedItems(1)        ' フォルダフルパスを変数格納
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Set Sh = ThisWorkbook.Worksheets("いいいいい")
    Col = Sh.Cells(1, Sh.Columns.Count).End(xlToLeft).Column
    fname = Dir(fold_path & "*.xls")
    Do Until Len(fname) = 0
        If fname <> ThisWorkbook.Name Then
            With Workbooks.Open(fold_path & "\" & fname, ReadOnly:=True)
                Col = Col + 1
                Sh.Cells(1, Col).Value = fname
                Sh.Cells(2, Col).Resize(632).Value = .Worksheets("あああああ").Range("E2:E633").Value
                .Close
            End With
        End If
        fname = Dir
    Loop
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Comments

[kihokutarou]

なるほど、selectしないアクセスしないというのがよくわかりました。50件程度でも数秒単位で差がわかりました。ありがとうございます。

Answer 2

あるファイルとは、どんな形式ですか？ＥＸＣＥＬ、ＣＳＶ、ＰＲＮ、ＲＤＢ？？

Comments

[sazi]

コード中に
fname = Dir(fold_path & "*.xls")
とあります。

Answer 3

FSOのファイル検索は高速とはいいがたいので、コマンドであらかじめファイルパスの取得をして、
配列に放り込んでおくとかなり高速化できるのではないかと思います。

Dim WSH, FilePath
Set WSH = CreateObject("WScript.Shell")

FilePath = WSH.Exec("dir """& fold_path &""" /s /b /a-d").StdOut.ReadAll
FilePath = Split(FilePath, vbCrLf) ''最終行が空で入るので気を付けてください

Comments

[kihokutarou]

ご回答ありがとうございます。
これ、挑戦してみたかったんですよね。なるほどファイル検索部分での短縮ですか。勉強になります。ちょっと参考にさせていただいて学習します。

Answer 4

処理中の内容を表示しないようにするのが一番効果的です。
以下参考
エクセルＶＢＡ高速化ランキング【第1位】

追記

コピーの部分は多少短縮できると思います。
無駄なSelectをしない

Comments

[kihokutarou]

大変申し訳ありません。質問のために整形していて
Application.ScreenUpdating = False
のセットを削除していました。
その上でもしなにかお知恵があればお願いします。

[sazi]

他にも割愛しているコードはありませんか？
コードの高速化が質問なので、割愛すると意味がありません。

[kihokutarou]

いえ、ほかには割愛している箇所はありません。
無駄なアクセスをしないということであれば、開いたブックの必要範囲を2次元配列にして最終的に書き出しをしたほうが良いかと気づかされました。
もう少し回答をお待ちしてみます。
ご回答ありがとうございます。

[sazi]

一旦配列に入れるのは無駄だと思います。
追加したリンク先の最後の方を参照して下さい。

[kihokutarou]

selectとはアクセスとも違う部分があるんですね、勉強になりました。具体的なコードを提示してくださった方もありますが、お教示いただいたことが勉強になりましたのでBAとさせていただきます。