【ＶＢＡ】サブフォルダーのファイル名称を取得する

フォルダーの中に入っているファイルの一覧がほしい！そんな時に使用できるＶＢＡコードを紹介をします。

概要
使い方
ソースコード

概要

紹介するコードの動作は任意のフォルダー内に存在するファイル名称とファイルパスの取得を行うツールです。今回は「ファイルパス」、「ファイルが存在するフォルダー名称」、「ファイル名称」、「更新日」、「拡張子」を取得しています。

使い方

下記の長いソースコードを貼り付けて使用してください。起動すれば自動的に「ファイルパス」「フォルダー名」「ファイル名」「更新日」「拡張子」を抽出したcsvファイルを作成します。任意のフォルダーへ作成したエクセルを移動させてから起動してください。

ソースコード

Dim YYY, YYY_2, XXX As Long
Dim CONT(1000), PASS_Z, FOLDER_NAME As String
Dim DATE1 As Date
Dim f, objFso, objFolder As Object

Sub GET_START()

Worksheets("取得").Activate
Call main_get
Call writeCSV

End Sub

Sub main_get()

YYY = 2
XXX = 2
YYY_2 = 2

Range("A2:Z10000").Delete
CONT(XXX) = ThisWorkbook.Path
    Call Get_SUB(ThisWorkbook.Path)
End Sub

Sub Get_SUB(Pass_1111 As String)

XXX = XXX + 1
Call GET_FOLDER(Pass_1111)

Set objFso = CreateObject("Scripting.FileSystemObject")

For Each f In objFso.GetFolder(Pass_1111).SubFolders
    FOLDER_NAME = f.NAME
    CONT(XXX) = FOLDER_NAME
     Call Get_SUB(f.Path)
Next f

Set objFso = Nothing
CONT(XXX) = ""
XXX = XXX - 1
End Sub


Sub GET_FOLDER(Pass1 As String)
Dim NAME As String
Dim NAME2 As String

NAME = Dir(Pass1 &amp; "\")

If NAME &lt;&gt; "" Then
    Do While NAME &lt;&gt; ""
        If NAME &lt;&gt; "." And NAME &lt;&gt; ".." Then
            Cells(YYY_2, 3).Value = NAME      'ファイル名称
            Cells(YYY_2, 2).Value = CONT(XXX - 1)    'フォルダ名称
            Call RE_NAME        'ファイルパス入力

            '更新日
            NAME2 = PASS_Z &amp; NAME
            Cells(YYY_2, 4).Value = FileDateTime(NAME2)   'ファイル更新日
           
            '拡張子
            Call GET_KK(NAME2)
            NAME = Dir()
        End If

        YYY_2 = YYY_2 + 1
        YYY = YYY + 1
        PASS_Z = ""
    Loop
ElseIf NAME = "" Then
        Call RE_NAME
        YYY = YYY + 1
        YYY_2 = YYY_2 + 1
End If

If PASS_Z &lt;&gt; "" Then
    PASS_Z = ""
End If

End Sub


Sub RE_NAME()

            For COUNT_A = 2 To XXX
                If CONT(COUNT_A) &lt;&gt; "" Then
                    PASS_Z = PASS_Z &amp; CONT(COUNT_A) &amp; "\"
                End If

            Next COUNT_A
            Cells(YYY_2, 1).Value = PASS_Z

End Sub


Sub GET_KK(PASS_K)
  Dim TEST_fso As New Scripting.FileSystemObject
  Dim filePath As String
  Dim ExtentionName As String

  filePath = PASS_K

  ExtentionName = TEST_fso.GetExtensionName(filePath)

  Cells(YYY_2, 5).Value = (ExtentionName)
  
  
  
  Set TEST_fso = Nothing
End Sub


Sub writeCSV()

Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(1)

Dim csvFile As String
csvFile = ActiveWorkbook.Path &amp; "\data" &amp; Year(Now()) &amp; "年" &amp; Month(Now()) &amp; "月" &amp; Day(Now()) &amp; " 日" &amp; " " &amp; Hour(Now()) &amp; "時" &amp; Minute(Now()) &amp; "分" &amp; Second(Now()) &amp; "秒" &amp; ".csv"

Open csvFile For Output As #1

Dim i As Long, j As Long
i = 1

Do While ws.Cells(i, 1).Value &lt;&gt; ""
    j = 1
    Do While ws.Cells(i, j + 1).Value &lt;&gt; ""
        Print #1, ws.Cells(i, j).Value &amp; ",";
        j = j + 1
    Loop
    Print #1, ws.Cells(i, j).Value &amp; vbCr;
    i = i + 1
Loop
Close #1

End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

Dim YYY, YYY_2, XXX As Long

Dim CONT(1000), PASS_Z, FOLDER_NAME As String

Dim DATE1 As Date

Dim f, objFso, objFolder As Object

Sub GET_START()

Worksheets("取得").Activate

Call main_get

Call writeCSV

End Sub

Sub main_get()

YYY = 2

XXX = 2

YYY_2 = 2

Range("A2:Z10000").Delete

CONT(XXX) = ThisWorkbook.Path

Call Get_SUB(ThisWorkbook.Path)

End Sub

Sub Get_SUB(Pass_1111 As String)

XXX = XXX + 1

Call GET_FOLDER(Pass_1111)

Set objFso = CreateObject("Scripting.FileSystemObject")

For Each f In objFso.GetFolder(Pass_1111).SubFolders

FOLDER_NAME = f.NAME

CONT(XXX) = FOLDER_NAME

Call Get_SUB(f.Path)

Next f

Set objFso = Nothing

CONT(XXX) = ""

XXX = XXX - 1

End Sub

Sub GET_FOLDER(Pass1 As String)

Dim NAME As String

Dim NAME2 As String

NAME = Dir(Pass1 & "\")

If NAME <> "" Then

Do While NAME <> ""

If NAME <> "." And NAME <> ".." Then

Cells(YYY_2, 3).Value = NAME 'ファイル名称

Cells(YYY_2, 2).Value = CONT(XXX - 1) 'フォルダ名称

Call RE_NAME 'ファイルパス入力

'更新日

NAME2 = PASS_Z & NAME

Cells(YYY_2, 4).Value = FileDateTime(NAME2) 'ファイル更新日

'拡張子

Call GET_KK(NAME2)

NAME = Dir()

End If

YYY_2 = YYY_2 + 1

YYY = YYY + 1

PASS_Z = ""

Loop

ElseIf NAME = "" Then

Call RE_NAME

YYY = YYY + 1

YYY_2 = YYY_2 + 1

End If

If PASS_Z <> "" Then

PASS_Z = ""

End If

End Sub

Sub RE_NAME()

For COUNT_A = 2 To XXX

If CONT(COUNT_A) <> "" Then

PASS_Z = PASS_Z & CONT(COUNT_A) & "\"

End If

Next COUNT_A

Cells(YYY_2, 1).Value = PASS_Z

End Sub

Sub GET_KK(PASS_K)

Dim TEST_fso As New Scripting.FileSystemObject

Dim filePath As String

Dim ExtentionName As String

filePath = PASS_K

ExtentionName = TEST_fso.GetExtensionName(filePath)

Cells(YYY_2, 5).Value = (ExtentionName)

Set TEST_fso = Nothing

End Sub

Sub writeCSV()

Dim ws As Worksheet

Set ws = ThisWorkbook.Worksheets(1)

Dim csvFile As String

csvFile = ActiveWorkbook.Path & "\data" & Year(Now()) & "年" & Month(Now()) & "月" & Day(Now()) & " 日" & " " & Hour(Now()) & "時" & Minute(Now()) & "分" & Second(Now()) & "秒" & ".csv"

Open csvFile For Output As #1

Dim i As Long, j As Long

i = 1