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

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

概要
使い方
ソースコード

概要

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

使い方

下記の長いソースコードを貼り付けて使用してください。起動すれば自動的に「ファイルパス」「フォルダー名」「ファイル名」「更新日」「拡張子」を抽出した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 & "\")

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

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

End Sub