| |
こんな形で善いと思うけど？
階層の勘定の仕方が人によって違うので
このコードの場合は、
探し始めるフォルダを0、その下のフォルダを1、またその下を2と
勘定しています
Option Explicit
Sub test_2()
Dim i As Long
Dim strFolderPath As String
Dim strSearchFile As String
Dim vntFileNames As Variant
' strFolderPath = "D:\mm\oo\tt\ee\" '検索ディレクトリ
strFolderPath = ThisWorkbook.Path
' strSearchFile = CStr(Cells(1, 1)) & "*" 'ファイル名（セルの値)
strSearchFile = CStr(Cells(1, 1)) & "*.xls" 'ファイル名（セルの値)
vntFileNames = FilesList(strFolderPath, strSearchFile, 3)
If vntFileNames(0) <> "" Then
For i = 0 To UBound(vntFileNames)
Workbooks.Open FileName:=vntFileNames(i)
Next i
Else
MsgBox "ファイルが見つかりません。"
End If
End Sub
Public Function FilesList(ByVal strFolderPath As String, _
ByVal strSearchFile As String, _
Optional lngSubDir As Long = -1) As Variant
'lngSubDirの値：探し始めのフォルダ=0、その下=1・・
Dim i As Long
Dim j As Long
Dim strFolders() As String
Dim strFileName As String
Dim strFileNames() As String
'パスの最後に\を付加
If Right(strFolderPath, 1) <> "\" Then
strFolderPath = strFolderPath & "\"
End If
'フォルダのListを作成
ReDim strFolders(0)
'探し始めるフォルダを代入
strFolders(0) = strFolderPath
'フォルダをリストアップ
If lngSubDir <> 0 Then
ListingFolders strFolderPath, strFolders(), _
UBound(strFolders) + 1, lngSubDir
End If
j = 0
ReDim strFileNames(j)
For i = 0 To UBound(strFolders)
'ディレクトリ内の全ての標準ファイルを列挙
strFileName = Dir(strFolders(i) & strSearchFile)
Do Until strFileName = ""
ReDim Preserve strFileNames(j)
strFileNames(j) = strFolders(i) & strFileName
j = j + 1
strFileName = Dir
Loop
Next i
FilesList = strFileNames()
End Function
Private Sub ListingFolders(ByVal strFilesPath As String, _
strDirList() As String, _
lngNextData As Long, _
lngSubDir As Long)
Dim i As Long
Dim j As Long
Dim lngNow As Long
Dim strFileName As String
'結果用配列の書き込み位置を取得
i = lngNextData
'サブディレクトリの結果リストと、一時的なリストを作成
strFileName = Dir(strFilesPath, vbDirectory)
Do Until strFileName = ""
'現在のディレクトリと親ディレクトリを無視
If strFileName <> "." And strFileName <> ".." Then
'ディレクトリ以外を無視
If GetAttr(strFilesPath & strFileName) _
And vbDirectory Then
ReDim Preserve strDirList(i)
'結果リストに追加
strDirList(i) = strFilesPath & strFileName & "\"
i = i + 1
End If
End If
strFileName = Dir
Loop
j = lngNextData
lngNextData = i
'ディレクトリの階層を一つ下げる
lngSubDir = lngSubDir - 1
'指定階層数になるまで再帰、lngSubDir < 0 の時は最終階層まで再帰
If lngSubDir > 0 Or lngSubDir < 0 Then
'各ディレクトリを再帰的に処理
For i = j To lngNextData - 1
lngNow = lngSubDir
ListingFolders strDirList(i), strDirList(), _
lngNextData, lngNow
Next i
End If
End Sub
|
|
Hirofumi
- 04/4/29(木) 14:15 -
