他の方の質問を参考に自作しましたが動作に時間が掛かる為、教えて下さい。
PCはWin10、エクセル2016、ファイル形式はxlsm
該当フォルダはネットワーク上\\○○○○\Users\ この中に複数ブックが存在
抽出したいデータは全てのブックの「メニュー」というSheetのA100からAO100までを
「集計.xlsm]のSheet1の２行目から抽出結果をA２からAO2までを２行目、３行目とずらして値で貼り付けたい
作成したVBAを見て良い方法をご教授下さい。
Sub 集約()
Dim myFolder As Variant
Dim fso As Object
Dim GetFolder As Object
Dim Fol As Object
Set fso = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show <> 0 Then
myFolder = .SelectedItems(1)
End If
End With
With CreateObject("WScript.Shell")
.CurrentDirectory = myFolder
End With
Set GetFolder = fso.GetFolder(myFolder)
For Each Fol In GetFolder.SubFolders
Debug.Print Fol.Name
Next
Set GetFolder = Nothing
'フォルダの場所を変数に入れる
Dim Folder_path As String
Folder_path = Range("a1").Value
'集計先のシートを指定し、変数に入れる
Dim w
Set w = Worksheets("sheet1")
'集計するブックを変数に入れる
Dim Merge_book As String
Merge_book = Dir(Folder_path & "\*.xlsm*")
'いったん数値をクリア
w.Range("b" & Rows.Count).Clear
'集計先のシートの1行からスタート
Dim n
n = 4
'指定したフォルダから、Excelファイルを探す
Do Until Merge_book = ""
Workbooks.Open FileName:=Folder_path & "\" & Merge_book
'見つかったら、A列にファイル名、B列に集計値を入れる
w.Range("a" & n).Value = Merge_book
w.Range("b" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("a100").Value
w.Range("c" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("b100").Value
w.Range("d" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("c100").Value
・・・・・・・・・・・・・・・省略・・・・・・・・・・・・・
・
("ao100").Value
w.Range("ap" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range
'次の行へ
n = n + 1
'集計するブックを閉じる
Workbooks(Merge_book).Close
'次のファイルを探しに行く
Merge_book = Dir()
Loop
End Sub
この方法は１つのフォルダ直下に全てのブックを入れないと動かないのでPCの容量に負担が掛かり画面もチラチラし、時間も掛かる為、もっと効率的な方法で作業を行いたいのです。
よろしくお願いいたします。
お礼
返事が遅くなりましてごめんなさい。母親の葬儀でドタバタしてまして 教えて頂いたものでやってみます。 ありがとうございました。