Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Excel 2016)
フォルダ内のbookを順次参照し処理で動作がもっさりしている
投稿日時: 20/11/05 09:11:40
投稿者: torao

お世話になっております。
 
データ集約用Bookと同じフォルダ内に保存されている
参照用Book(10ファイルある)のデータを集約したいと考えております。
 
(フォルダ構成)
 
基礎データフォルダ
 └データ_〇〇.xlsm・・・WbB(参照したいBook群)
 └データ_〇〇.xlsm
 └データ_〇〇.xlsm
 └データ_〇〇.xlsm
 └データ_〇〇.xlsm
 └データ_〇〇.xlsm
 └データ集約用.xlsm・・・WbA(集約用Book)
 
処理の流れは以下のようにしています。
・データ集約用Book(WbA)と同じフォルダ内にある
・参照用Book(WbB)のデータをWorkbooks.Open FileName:=WbB_File.path, ReadOnly:=Trueで開いて
・データ転記(WbB→(WbA)
・閉じる(WbB)
 
(質問です)
 
処理自体はできています。
気になるのは、下記コード内「'★もっさりしている2-3秒くらい↓〜ここまで↑」の部分です。
 
 ・フォルダ内の指定ファイル名を「If WbB_FName Like "データ*" Then」で検索し
 ・ファイルがあれば→開く
 
ここまでの処理が何となくもっさりしています。
 
 ※フォルダ内のデータはテスト段階のため参照ファイルのみ配置しております。
  ・データ_〇〇.xlsmのみ10ファイルです。
  ・ファイルサイズは500KB
  ・マクロ有効Bookで数式は20個程度で外部参照なし(処理のためマクロ停止させている)
 
初めてのフォルダ参照マクロを組んでいますので、感覚的にこのようなものかどうかもわかりません。
もしかしたら、コード自体に無駄があるのかもしれません。
皆様、どうかアドバイスのほどよろしくお願いします。
 
 
Sub 基礎データ取り込み()
    Dim mse As Integer: mse = MsgBox("データ照合処理を行います", vbYesNo, "フォルダ参照")
    If Not mse = vbYes Then
        MsgBox "キャンセル", vbOKOnly, "フォルダ参照"
        Application.ScreenUpdating = True
        Exit Sub
    End If
    '-----------------------------------------------------------------------------------
    '今開いている取込み元(WbA)を定義
    '-----------------------------------------------------------------------------------
    Dim WbA As String: WbA = Application.ActiveWorkbook.name
    Dim WbA_sh1 As Worksheet: Set WbA_sh1 = Workbooks(WbA).Worksheets("集約")
 
'★もっさりしている2-3秒くらい ↓ファイルの特定〜開くまで
 
    '-----------------------------------------------------------------------------------
    '処理対象フォルダの定義:Tool自身=処理対象ファイルのあるフォルダパスを設定
    '-----------------------------------------------------------------------------------
    Dim FolderPath As String: FolderPath = ThisWorkbook.path & "\" '自身のフォルダパス格納
    '配列(FileSystemObject)にファイル名諸々の情報を格納
    Dim FSO As Scripting.FileSystemObject: Set FSO = New Scripting.FileSystemObject
    Dim BaseFolder As Scripting.Folder: Set BaseFolder = FSO.GetFolder(FolderPath)
    Dim WbB_Files As Scripting.files: Set WbB_Files = BaseFolder.files
    Dim WbB_File As Scripting.file '参照ファイルパス格納
    '----------------------------------------------------------------------------------------
    'フォルダ内の取込む対象ファイル(WbB)を参照し処理(WbBデータをWbAへ転記)
    '----------------------------------------------------------------------------------------
    Application.ScreenUpdating = False
    Dim i As Long, WbA_sh1row As Long, WbB_sh1row As Long
    Dim WbB_FName As String, WbB_sh1 As Worksheet '参照先(WbB)を定義
    For Each WbB_File In WbB_Files
        '取り込む対象ファイル名のみを取得(※隠しファイル有/$ファイル名あるので注意)
        WbB_FName = Dir(WbB_File)
        '対象ファイル名があれば処理
        If WbB_FName Like "データ*" Then
            'WbBファイルを開く/Book構成取得/非表示
            With Application
                .StatusBar = "[処理中...] " & WbB_File '進捗表示
                .DisplayAlerts = False '警告/メッセージ停止
                .EnableEvents = False 'マクロ停止
                Workbooks.Open FileName:=WbB_File.path, ReadOnly:=True '読み取り専用で開く
                ActiveWindow.Visible = False 'Windows(WbB_FName).Visible = False '非表示
                Set WbB_sh1 = Workbooks(WbB_FName).Worksheets("リスト")
                .EnableEvents = True
                .DisplayAlerts = True
            End With
 
'★ここまで ↑
 
 
            '取り込み処理(配列内で処理)
 
                                            
            'WbBを閉じる
            With Application
                .DisplayAlerts = False
                Workbooks(WbB_FName).Close SaveChanges:=False
                Set WbB_sh1 = Nothing '参照解除
                .StatusBar = False '進捗解除
                .DisplayAlerts = True
            End With
        End If
    Next WbB_File
    Application.ScreenUpdating = True
    MsgBox "完了", vbOKOnly, "フォルダ参照"
End Sub

投稿日時: 20/11/05 12:24:49
投稿者: torao

追記です。
 
フォルダの保存先はテストフォルダとして
 
デスクトップに配置しております。

回答
投稿日時: 20/11/05 14:42:27
投稿者: mattuwan44

2〜3秒が速いのか遅いのかは実験してみないとわかりませんが、
FSOは若干遅いようなので、
Dir関数のみでファイルを検索してみてはいかがでしょう?
さらっと読んだだけですので何とも言えませんが、
FSOをあえて使うメリットはなさそうです。
 
サンプルコードはネット上にいくつか落ちているはずです。探してみてください。

回答
投稿日時: 20/11/05 15:49:09
投稿者: Suzu

原因がコードが要因なのかどうなのか
実際のファイルを『手動』で開いた場合にの時間はどうなのでしょうか。
 
まずはその確認からではないでしょうか。
 
 
コードに関しては
 
FSO と DIR を併用する必要はないように見えます。
 
開くファイルがリンクが貼られていて、更新の必要が無いのであれば UpDateLink にFalse
読み取り専用を推奨 の抑制が必要であれば、Ignorereadonlyrecommended に True
 
ブックファイル開く前に メッセージ と、イベント の オン/オフ を繰り返す意図はなんでしょうか?
マクロの最初 から 最後まで、オフにしてしまえば良いのではありませんか?
 
複数のブックを扱う場合には、
明示的に 自ブック・開く先のブック をオブジェクト変数で受けたほうが良いです。
 
ブックを閉じた後に、シートの参照を開放しています。逆の方が良いでしょう。
 
 
 

Sub Sample()
    On Error GoTo Err_Sample

    Dim xlsApp  As Excel.Application
    Dim wbk     As Excel.Workbook
    Dim wst     As Excel.Worksheet

    Dim strPath As String
    Dim strFile As String

    Set xlsApp = Excel.Application
    With xlsApp
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With

    strPath = xlsApp.ThisWorkbook.Path
    strFile = Dir(strPath & "\データ*.xlsm")

    Do While Not strFile = ""
        MsgBox strFile

        xlsApp.StatusBar = "[処理中...] " & strFile

        Set wbk = xlsApp.Workbooks.Open(Filename:=strPath & "\" & strFile, UpdateLinks:=False, ReadOnly:=True, Ignorereadonlyrecommended:=True)
        'Set wst = wbk.Worksheets("リスト")

        '処理

        Set wst = Nothing
        wbk.Close SaveChanges:=False

        strFile = Dir()
    Loop

Exit_Sample:
    Set wst = Nothing
    Set wbk = Nothing

    If Not xlsApp Is Nothing Then
        With xlsApp
            .StatusBar = False
            .EnableEvents = True
            .DisplayAlerts = True
            .ScreenUpdating = True
        End With
    End If
    Set xlsApp = Nothing

    MsgBox "Finish!"

    Exit Sub

Err_Sample:
    MsgBox Err.Description, , Err.Number
    Resume Exit_Sample
End Sub

投稿日時: 20/11/05 17:07:28
投稿者: torao

mattuwan44さん
Suzuさん
 
ありがとうございます。
ネットで参考になるものを切り張りした状態だったので、FSO と DIR を併用もそうですが、改善の必要があることが分かっただけでも感謝です。
 
提示いただいたコードと自身のコードを計測しました。
 
ファイルを一つづつ「開いて閉じる」を10個
 
・自身のコード:平均4.613
・Suzuさんのコード:平均4.214
 
試しにファイル数を50個ほど処理すると
タイム差が広がっていって、断然Suzuさんのコードが速かったです。
 
 
 
Suzuさんのコードを参考に見直したいと思います。
 
 
 

回答
投稿日時: 20/11/05 19:44:10
投稿者: mattuwan44

Sub test()
    Dim vFileList As Variant
    Dim vFile As Variant
    Dim ixRow As Long
    Dim wbk As Workbook
    Dim rngCopy As Range
    
    If GetFileList(ThisWorkbook.Path, "データ*", vFileList) = False Then Exit Sub
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    ixRow = 2
    For Each vFile In vFileList
        Set wbk = Workbooks.Open(vFile)
        Application.StatusBar = wbk.Name & "処理中・・・・"
        
        転記 wbk, ThisWorkbook.Worksheets("集約"), ixRow
        
        wbk.Close False
    Next
    
    With Application
        .EnableEvents = True
        .StatusBar = False
    End With
End Sub

Private Function GetFileList(ByVal sPath As String, ByVal sName As String, ByRef pFileList() As Variant) As Boolean
    Dim i As Long
    Dim p As String
    Dim buf As String
    
    ReDim pFileList(1000)
    p = sPath & "\" & sName & ".xlsm"
    i = -1
    
    buf = Dir(p)
    Do Until Len(buf) = 0
        i = i + 1
        pFileList(i) = sPath & "\" & buf
        buf = Dir()
    Loop
    
    If i > -1 Then
        ReDim pFileList(i)
        GetFileList = True
    End If
End Function

Private Sub 転記(ByRef wbkFrom As Workbook, ByRef wshTo As Worksheet, ByRef ix As Long)
    With wbkFrom.Worksheets(1).UsedRange
        .Copy wshTo.Cells(ixRow, 1)
        ix = ix + .Rows.Count
    End With
End Sub

 
時間作れたので、コード書いてみました。
動作確認はしてません。
 
ほんとに必要か必要でないかわからない部分は省略
保存せずに閉じるなら、読み取り専用だろうがそうでなかろうが同じかと思いました。
あと、画面の更新を止めたら表示非表示も関係ないし、、、
閉じるときも保存しないならメッセージは出ないですよねー。。。。
(他で何か出るかも?)
 
ループが2重に行われる分時間がかかるかも。
ま、処理時間よりわかりやすさ優先で。。。^^;(わかりやすいのかな?^^;)

回答
投稿日時: 20/11/06 09:45:30
投稿者: Suzu

引用:
下記コード内「'★もっさりしている2-3秒くらい↓〜ここまで↑」の部分です。

★部分は、1ファイル当りの処理 時間ですよね。
 
引用:
ファイルを一つづつ「開いて閉じる」を10個
・自身のコード:平均4.613
・Suzuさんのコード:平均4.214

数字は秒で、10ファイルの処理時間だとすれば・・
 
当初の数値とはだいぶ差がありますね。
 
コードの効率化を行っても、0.4秒の差であり誤差とも言える範囲と考えます。
5倍の50ファイルだとしても2秒の差です。
当方の感覚では toraoがおっしゃる「もっさり」と言える差では無いと考えます。
 
コードの無駄は確かにあると思いますが、初めてとの事ですので
参考コードを ステップ実行を行い、処理内容を追って行き、身につけて行けば良いと思います。
 
 
mattuwan44 さん
引用:
保存せずに閉じるなら、読み取り専用だろうがそうでなかろうが同じかと思いました。
あと、画面の更新を止めたら表示非表示も関係ないし、、、
閉じるときも保存しないならメッセージは出ないですよねー。。。。
(他で何か出るかも?)

以前
DisplayAlerts = False
Visible = False
にて、処理していて、全然終わらない事がありまして。。
バックグランドでダイアログが出てしまい、処理が中断している事がありました。
直接の原因は覚えていませんが、ファイル固有の問題だった記憶があります。
 
当方も、サブルーチンにて事前にファイルリストを取得する方法が汎用性も高いしメンテナンスも楽なので使って居たのですが、複数人が使用する環境で、ファイルを削除された事がありました。
読み取り専用の方がファイルを開く処理が速かったので、処理速度を求める場合には使用する様にしています。
あとは、ローカルにコピーする事を先にしてしまう事もありますね。
 
 
以下は修正が必要かと思います。
Private Function GetFileList(ByVal sPath As String, ByVal sName As String, ByRef pFileList() As Variant) As Boolean
 ↓
Private Function GetFileList(ByVal sPath As String, ByVal sName As String, ByRef pFileList As Variant) As Boolean
 
    ReDim pFileList(1000)
 ↓
    ReDim Preserve pFileList(1000)
 
       .Copy wshTo.Cells(ixRow, 1)
 ↓
        .Copy wshTo.Cells(ix, 1)

投稿日時: 20/11/07 12:37:11
投稿者: torao

mattuwan44 さん
 
ありがとうございます。
 
Private Function関数化、まだ挑戦したことのない分野(避けてきた)
この際、勉強したいと思います。
 
Suzu さん
 
コードを自身のものと置き換えながら作成しました。
かなりスッキリできました。
 
Do While Loop は今回初挑戦です(無限ループが怖くて避けてきた)
 
現在、開いたBookからデータを取り出すコードを作成中です。
改めてご報告させていただきます。

回答
投稿日時: 20/11/07 21:44:16
投稿者: K.Hiwasa
投稿者のウェブサイトに移動

こんばんは。DirとFSOについて。
 
Dirは長いパス(260文字超)の場合、エラーになりますが、FSOでは処理できます。
自作のツールで以前はDirで処理していましたが、上記エラーのためFSOに変更しました。
パスが明らかに長くならない場合は、Dirで問題ないと思います。
ネットワーク上の深いフォルダとかの場合、長いパスになったりすることがあります。

回答
投稿日時: 20/11/08 20:55:48
投稿者: hatena
投稿者のウェブサイトに移動

Workbooks.Openは基本的に重い処理ですので、Dirを使うとか、いろいろテクニックはありますが、劇的な火l全は難しいですね。
 
下記のようにExcel.Applicationを別インスタンスで開いて、処理するとかなり改善されます。
 
Dim xlsApp As New Excel.Application
 
Set wbk = xlsApp.Workbooks.Open(・・・)
 
こうすることによって、裏で完全非表示で処理させるので完全されるようです。
 
あとは、Workbooks.Openでブック開かずにデータを取得する方法で劇的に改善されます。
 
ブックを開かずに取得する方法としては、外部参照を使う方法、ADOを使う方法があります。
下記が参考にないと思います。
 
VBA - ブックを開かずデータを取得したい|teratail
https://teratail.com/questions/264303

回答
投稿日時: 20/11/08 21:19:47
投稿者: hatena
投稿者のウェブサイトに移動

訂正(;^_^A
 
劇的な火l全は難しいですね。

劇的な改善は難しいですね。

投稿日時: 20/11/10 10:39:42
投稿者: torao

hatenaさん
 
ありがとうございます。
 
 
Dim xlsApp As New Excel.Application
 
こういうやり方があるのですね。
勉強になります。

投稿日時: 20/12/24 10:08:59
投稿者: torao

すみません。解決ボタンおすの忘れていました。
 
無事に、取り込みが出来るようになり、もっさり感も解消できました。