エクセルでまあまあの速さでディレクリを取り込むには

エクセルでまあまあの速さでディレクリを取り込むにはどうしたらよいでしょうか。
特定のディレクトリを指定して、その配下にあるファイル一覧のシートを作りたいと思っています。
VBAでFileSystemObjectオブジェクトを使って再帰的にサブルーチンを呼ぶ方法でVBAを作りました。
一応動くのですが、とてもスピードが遅いのです。
サーバー上のディレクリなのでローカルほど早くないのは当然ですが、Windowsの検索（ファイルやフォルダ）では、そこそこの速さで動きます。
Dir関数に替えてみましたが、スピードはほとんど変わりません。
エクセルでなくとも結果を記録できれば他のツールでも良いのですが、
使えるツールが非常に限られています。
職場のPCですが、Windows2000Proの初期状態にOffice2000がインストールされています。
セキュリティ上、他のソフトのインストールや使用は禁止されています。
何か良い方法はないでしょうか。
よろしくお願い申し上げます。

No.1 ベストアンサー 回答者： ham_kamo 回答日時： 2006/12/08 23:10

tree /f ディレクトリ名

を実行して、その結果を取りこむとか。サーバ上で速いかどうかはわかりませんが。

この回答へのお礼

回答ありがとうございます。
DOS窓があることをすっかり忘れていました。
これで適当なテキストファイルにリダイレクトすればいいわけですな。
エクセルを実行しているとその間エクセルが使えなくなるので、これでトライしてみます。

お礼日時：2006/12/08 23:44

No.3 回答者： imogasi 回答日時： 2006/12/09 12:00

＃２のご回答があるのに、こんな回答で、的外れかも知れませんが

どうでしょう。質問の前提を見落としていたらすみません。
１００ファイルあたり１秒ぐらい。
マイドキュメントのファイルの例
strPath は自分のケースに変えてください。
Sub test01()
Dim strPath As String
Dim strFullPath As String
Dim Fname As String
i = 1
'----
strPath = "C:\Documents and Settings\ｘｘｘｘ\My Documents" '"ActiveWorkbook.Path '

strFullPath = strPath & "\*.*"
Fname = Dir(strFullPath)
'----
Do While Fname <> ""
Cells(i, "A") = Fname
i = i + 1

Fname = Dir()
Loop
'----

End Sub

この回答へのお礼

回答ありがとうございます。
実行中もエクセルが使えそうな（実際にやってみないとわかりませんが）＃１の方の案を採用し、エクセルに取り込むVBAを作成しました。
皆様ありがとうございました。

お礼日時：2006/12/09 13:13

No.2 回答者： KenKen_SP 回答日時： 2006/12/09 03:40

こんばんは。

KenKen_SP です。

> 一応動くのですが、とてもスピードが遅いのです。
ファイルオペレーションは圧倒的に C 言語が高速ですが、VB(A) でもファイル
検索用 API が使えます。試してみてください。結構高速ですよ。
ローカル検索だと Windows の検索に近い速度ですが、ネットワーク経由の
場合、通信トラフィックの状況にかなり影響されると思いますけどね...

あとは、VB(A) なら FileSearch オブジェクトを使う方法も早いかもしれません。
しかし、挙動不安定で、さらに列挙の順番がバラバラなので使い難いです。

では。

' Declarations ----------------------------------------------------------------
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
　　　　ByVal lpFileName As String, _
　　　　ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
　　　　ByVal hFindFile As Long, _
　　　　ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" ( _
　　　　ByVal hFindFile As Long) As Long

' Constants -------------------------------------------------------------------
Private Const MAX_PATH　　　　　　　　 As Long = 260
Private Const INVALID_HANDLE_VALUE　　 As Long = (-1)
Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10

' Types -----------------------------------------------------------------------
Private Type FILETIME
　　dwLowDateTime　　　 As Long
　　dwHighDateTime　　　As Long
End Type
Private Type WIN32_FIND_DATA
　　dwFileAttributes　　As Long
　　ftCreationTime　　　As FILETIME
　　ftLastAccessTime　　As FILETIME
　　ftLastWriteTime　　 As FILETIME
　　nFileSizeHigh　　　 As Long
　　nFileSizeLow　　　　As Long
　　dwReserved0　　　　 As Long
　　dwReserved1　　　　 As Long
　　cFileName　　　　　 As String * MAX_PATH
　　cAlternate　　　　　As String * 14
End Type

' // ファイルを検索する(再帰呼び出し使用）
Public Sub FindFile( _
　　　 ByRef Buffer() As String, _
　　　 ByVal DirPath As String, _
　　　 ByVal SearchFileName As String, _
　　　 Optional ByVal CheckSubFolder As Boolean = False _
)

　　' @引　数： Buffer() String配列 ここにファイルパスが保管されます
　　'　　　　： DirPath　検索ルートフォルダのパス
　　'　　　　： SearchFileName 検索ファイル名（ワイルドカード OK）
　　'　　　　： [CheckSubFolder] 省略可 サブフォルダも検索するか？

　　Dim WFD　　　　　As WIN32_FIND_DATA
　　Dim hFind　　　　As Long
　　Dim i　　　　　　As Long
　　Dim j　　　　　　As Long
　　Dim DirName　　　As String
　　Dim FileName　　 As String
　　Dim SubFolders() As String

　　' パス終端の補正
　　If Right$(DirPath, 1) <> "\" Then DirPath = DirPath & "\"
　　' サブフォルダ列挙
　　i = -1
　　If CheckSubFolder Then
　　　　hFind = FindFirstFile(DirPath & "*", WFD)
　　　　If hFind <> INVALID_HANDLE_VALUE Then
　　　　　　Do
　　　　　　　　DirName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1)
　　　　　　　　If DirName <> "." And DirName <> ".." Then
　　　　　　　　　　If CBool(WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
　　　　　　　　　　　　i = i + 1
　　　　　　　　　　　　ReDim Preserve SubFolders(i)
　　　　　　　　　　　　SubFolders(i) = DirPath & DirName
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　Loop Until FindNextFile(hFind, WFD) = 0
　　　　　　FindClose (hFind)
　　　　End If
　　End If
　　' ファイル列挙
　　hFind = FindFirstFile(DirPath & SearchFileName, WFD)
　　If hFind <> INVALID_HANDLE_VALUE Then
　　　　Do
　　　　　　FileName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1)
　　　　　　If FileName <> "." And FileName <> ".." Then
　　　　　　　　If CBool(WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = False Then
　　　　　　　　　　On Error Resume Next
　　　　　　　　　　j = UBound(Buffer) + 1
　　　　　　　　　　If Err Then j = 0
　　　　　　　　　　On Error GoTo 0
　　　　　　　　　　ReDim Preserve Buffer(j)
　　　　　　　　　　' ここでファイルパス＋ファイル名で返してます
　　　　　　　　　　Buffer(j) = DirPath & FileName
　　　　　　　　　　j = j + 1
　　　　　　　　End If
　　　　　　End If
　　　　Loop Until FindNextFile(hFind, WFD) = 0
　　　　FindClose (hFind)
　　End If
　　' サブフォルダ探索
　　If CheckSubFolder And i > -1 Then
　　　　For i = 0 To UBound(SubFolders)
　　　　　　' サブフォルダ再帰呼び出し
　　　　　　Call FindFile(Buffer, _
　　　　　　　　　　　　　SubFolders(i), _
　　　　　　　　　　　　　SearchFileName, _
　　　　　　　　　　　　　CheckSubFolder)
　　　　Next i
　　End If

End Sub

' // 使い方サンプル
Sub Sample()

　　Dim Buf() As String
　　Dim i　　 As Long
　　
　　' 全ファイルの列挙なら検索ファイル名を *.* にする
　　Call FindFile(Buf(), "C:\", "*.bmp", True)
　　
　　' 出力
　　On Error Resume Next
　　i = UBound(Buf) + 1
　　On Error GoTo 0
　　If i = 0 Then
　　　　MsgBox "該当ファイルは見つかりません", vbExclamation
　　Else
　　　　If i > Rows.Count Then
　　　　　　ReDim Preserve Buf(Rows.Count)
　　　　　　MsgBox "該当ファイルは" & Format$(i, "#,##0") & "件" & vbLf _
　　　　　　　　 & "全件表示できません", vbInformation
　　　　End If
　　　　With ActiveSheet
　　　　　　.Cells.Delete
　　　　　　.Cells(1, 1).Resize(i).Value = Application.Transpose(Buf)
　　　　End With
　　End If

End Sub

この回答への補足

自宅で実行しました。速いですね。
tree /f結果をエクセルに取り込むVBAを書くか、貴殿のVBAを打ち込むか悩ましいところですね。

補足日時：2006/12/09 07:39

この回答へのお礼

長いプログラム、あありがとうございます。
頑張って打ち込んでみます。
何せ勤め先のセキュリティはとても厳しく、インターネットに接続できませんし、FD、CD、メモリースティックもアラームがでます。
ひたすら打ち込むしかありません。

お礼日時：2006/12/09 07:33