Sub Sample()
Dim ofdFD As Office.FileDialog
Dim objFS As New FileSystemObject
Dim strPath As String
Dim FName As String
Dim cnt As Long
strPath = ThisWorkbook.Path 'このVBAコードのあるファイルのパスを指定
Set ofdFD = Application.FileDialog(msoFileDialogFolderPicker)
With ofdFD 'ダイヤログボックスの設定
'ダイヤログボックスのファイル表示の設定
.InitialView = msoFileDialogViewDetails
'複数選択をしないよう設定
.AllowMultiSelect = False
End With
Application.ScreenUpdating = False '画面更新を非表示にする
Application.DisplayAlerts = False '警告文を非表示にする
If ofdFD.Show() = -1 Then 'OKや参照・開くなどを押すと返り値【-1】が返ってくる
Set getf = objFS.GetFolder(ofdFD.SelectedItems(1))
DoEvents
For Each fl In getf.SubFolders ' フォルダ一覧を取得
cnt = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ChDir fl.Path
FName = Dir("*.xls")
Do While FName <> ""
Workbooks.Open FName '対象ファイルを開く
ThisWorkbook.Sheets(1).Cells(cnt, 2) = FName 'ファイル名
ThisWorkbook.Sheets(1).Cells(cnt, 1) = Sheets(1).Cells(1, 1).Value '取得したいセルの位置
ThisWorkbook.Sheets(1).Cells(cnt, 3) = fl '対象ファイルがあるフォルダー
cnt = cnt + 1
ActiveWorkbook.Close '対象ファイルを閉じる
FName = Dir()
Loop '繰り返す
Next fl
Else
MsgBox "キャンセルが押されました"
End If
Set ofdFD = Nothing
Application.DisplayAlerts = True '警告文を表示する
Application.ScreenUpdating = True '画面更新表示する
End Sub
コメントを残す