| |
▼ぴょんきち さん：
こんにちは
サブフォルダもということなら、いろいろ方法はありますが、わりとポピュラーな
ＦＳＯの例です。（最初にアップしたSample2の方式）
Sub Sample3()
Dim myPath As String
Dim myFso As Object
Dim myPool As Collection
Dim myFold As Object
Dim myData As Variant
myPath = Get_Folder
If myPath = "" Then Exit Sub
Set myFso = CreateObject("Scripting.FileSystemObject")
Set myFold = myFso.getfolder(myPath)
Set myPool = New Collection
Call getBooks(myFold, myPool) '中でサブフォルダ内も再帰で検索
For Each myData In myPool
MsgBox myData(0) & vbLf & myData(1)
'myData(0) ブック名
'myData(1) ブックのフルパス
'ここでシートにファイル名を追加編集
Next
Set myFso = Nothing
Set myFold = Nothing
Set myPool = Nothing
End Sub
Private Sub getBooks(fold As Object, myPool As Collection)
Dim myFile As Object
Dim myFold As Object
For Each myFile In fold.Files
If StrConv(Right(myFile.Name, 4), vbLowerCase) = ".xls" And _
myFile.Name <> ThisWorkbook.Name Then
myPool.Add Array(myFile.Name, myFile.Path)
End If
Next
For Each myFold In fold.subfolders
Call getBooks(myFold, myPool) '再帰によるサブフォルダ検索
Next
End Sub
Private Function Get_Folder() As String
Dim ffff As Object
Dim WSH As Object
Set WSH = CreateObject("Shell.Application")
Set ffff = WSH.BrowseForFolder(&H0, "フォルダを選択してください", &H1 + &H10)
If ffff Is Nothing Then
Get_Folder = ""
Else
Get_Folder = ffff.Items.Item.Path
End If
Set ffff = Nothing
Set WSH = Nothing
End Function
|
|
UO3
- 11/3/29(火) 10:11 -
