code-depot for VBA

URL / Comment

'-----------------------------------------------------------

'■ループでディレクトリ探索

'abyssinia.bbs.fc2.com/ act=reply&tid=2800138#14526246

'

'再帰を使わず、ループでディレクトリを舐めるコードです。

'半分ジョークですが、意外とシンプルに書けたので。

'

'※要参照設定

'※システムフォルダとか切り分けてないので

'　対象フォルダによっては止まります。

 

'-------------------------------------------------

Declare Function timeGetTime Lib "winmm.dll" () As Long

 

Sub Sample()

 

  '■宣言-----------------------------------------

  Const tgPth As String = "D:\hoge"

  

  Dim myFSO           As New Scripting.FileSystemObject

  Dim myFld           As Folder

  Dim myObj           As Object

  Dim stAry(1, 99999) As Variant

  Dim lvIdx           As Long

  Dim rmCnt           As Long

  Dim rwIdx           As Long

  

  Dim t As Long

  t = timeGetTime

  

  Application.ScreenUpdating = False

  Cells.Clear

  

  '■初期値---------------------------------------

  stAry(0, 0) = tgPth

  stAry(1, 0) = 1

  rmCnt = 0

  rwIdx = 0

  

  '■探索-----------------------------------------

  Do Until rmCnt < 0

  

    lvIdx = stAry(1, rmCnt)

  

    'フォルダ名書出---------------------

    Set myFld = myFSO.GetFolder(stAry(0, rmCnt))

    rwIdx = rwIdx + 1

    Cells(rwIdx, lvIdx).Value = myFld.Name

    rmCnt = rmCnt - 1

 

    'サブフォルダ探索-------------------

    For Each myObj In myFld.SubFolders

      rmCnt = rmCnt + 1

      stAry(0, rmCnt) = myObj.Path

      stAry(1, rmCnt) = lvIdx + 1

    Next myObj

    

    'ファイル探索／書出-----------------

    For Each myObj In myFld.Files

      rwIdx = rwIdx + 1

      Cells(rwIdx, lvIdx + 1).Value = myObj.Name

    Next myObj

    

  Loop

  

  Debug.Print rwIdx, timeGetTime - t

End Sub

'-----------------------------------------------------------