| |
▼にしもり さん：
その他の方法として 以下の2方法もあると思います。
(1)貼付行も 呼び出し時にパラメータ（引数）として渡す方法
Sub Sample()
Call FileSearch("C:\_cosmos\Tr")
End Sub
'「貼付け行」も呼び出し側で指定する
Sub FileSearch(Path As String, 貼付行 As Long)
Dim Folder As Object
Dim File As Object
With CreateObject("Scripting.FileSystemObject")
For Each Folder In .GetFolder(Path).SubFolders
Call FileSearch(Folder.Path, 貼付行)
For Each File In .GetFolder(Path).Files
貼付行 = 貼付行 + 1
Cells(貼付行, 1).Value = File.Path
Next File
Next Folder
End With
End Sub
(2) 上の方法は FSOを使っていることと、1ファイルづつ都度セルに
書き込んでいるので、ファイル数が多くなると遅くなります。
Dirコマンドで検索し、検索結果を配列に格納して シートに
一括して書き込むようにすれば、格段にスピードアップします。
Sub Sample2()
Dim n As Long
Dim FoundFiles() As String
n = SearchFiles("C:\_cosmos\Tr", "*.*", FoundFiles())
If n > 0 Then
Range("B1").Resize(n).Value = _
Application.Transpose(FoundFiles)
End If
End Sub
'//サブフォルダを含むファイルの一覧
Function SearchFiles(LookIn As String, Filename As String, _
FoundFiles() As String) As Long
Dim i As Long
Dim Ext As Variant
Dim tmpPath As String
Dim sCmd As String
Dim ko As Long
If Right$(LookIn, 1) <> "\" Then LookIn = LookIn & "\"
If InStr(Filename, ";") > 0 Then
Ext = Split(Filename, ";")
For i = 0 To UBound(Ext)
Ext(i) = LookIn & Ext(i)
Next
Filename = Join(Ext, """ """)
Else
Filename = LookIn & Filename
End If
tmpPath = LookIn & "Dir.tmp" 'Dirの結果を一時ファイルに出力
sCmd = "DIR """ & Filename & """ /b/s/o:N > """ & tmpPath & """"
'' /b ファイル名のみ
'' /s サブディレクトリも検索
'' /o:N 名前順でソート
With CreateObject("WScript.Shell")
ko = .Run("CMD /C " & sCmd, 7, True) 'Dirコマンド実行
End With
If ko Then
MsgBox "ファイルの検索に失敗しました", , LookIn
Exit Function
End If
If FileLen(tmpPath) < 2 Then Exit Function
Dim io As Integer
Dim buf() As Byte
io = FreeFile()
Open tmpPath For Binary As io
ReDim buf(1 To LOF(io))
Get #io, , buf
Close io
Kill tmpPath
FoundFiles() = Split(StrConv(buf, vbUnicode), vbCrLf)
ko = UBound(FoundFiles)
ReDim Preserve FoundFiles(ko - 1)
SearchFiles = ko
End Function
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
