VBA Dir関数でワイルドカード検索する方法｜フォルダ内のファイル名取得も解説

Option Explicit

Sub ListXlsxFilesByDir()
    Const FOLDER_PATH As String = "C:\サンプル\"

    Dim ws As Worksheet
    Dim fileName As String
    Dim nextRow As Long

    Set ws = ThisWorkbook.Worksheets("Sheet1")

    ws.Range("A:A").ClearContents
    ws.Range("A1").Value = "ファイル名"

    nextRow = 2
    fileName = Dir(FOLDER_PATH & "*.xlsx")

    Do While fileName <> ""
        ws.Cells(nextRow, 1).Value = fileName
        nextRow = nextRow + 1
        fileName = Dir()
    Loop
End Sub

Option Explicit

Sub GetFirstXlsxFileName()
    Const FOLDER_PATH As String = "C:\サンプル\"

    Dim fileName As String

    fileName = Dir(FOLDER_PATH & "*.xlsx")

    If fileName <> "" Then
        Worksheets("Sheet1").Range("A1").Value = fileName
    Else
        Worksheets("Sheet1").Range("A1").Value = "該当ファイルなし"
    End If
End Sub

Option Explicit

Sub ListCsvFiles()
    Const FOLDER_PATH As String = "C:\サンプル\"

    Dim fileName As String
    Dim nextRow As Long

    nextRow = 2
    fileName = Dir(FOLDER_PATH & "*.csv")

    Do While fileName <> ""
        Worksheets("Sheet1").Cells(nextRow, 1).Value = fileName
        nextRow = nextRow + 1
        fileName = Dir()
    Loop
End Sub

fileName = Dir(FOLDER_PATH & "*.xlsx")

Do While fileName <> ""
    Debug.Print fileName
    fileName = Dir()
Loop

'カレントフォルダから探す
Debug.Print Dir("*.xlsx")

'指定フォルダから探す
Debug.Print Dir("C:\サンプル\*.xlsx")

Dim folderPath As String
Dim fileName As String
Dim fullPath As String

folderPath = "C:\サンプル\"
fileName = Dir(folderPath & "*.xlsx")

If fileName <> "" Then
    fullPath = folderPath & fileName
    Debug.Print fullPath
End If

fileName = Dir("C:\サンプル\*.*", vbHidden Or vbReadOnly)

If (GetAttr("C:\サンプル\集計") And vbDirectory) = vbDirectory Then
    Debug.Print "フォルダです"
End If

'OK
fileName = Dir("C:\サンプル\" & "*.xlsx")

'NGになりやすい
fileName = Dir("C:\サンプル" & "*.xlsx")

Private Function AddTrailingBackslash(ByVal folderPath As String) As String
    If Len(folderPath) = 0 Then
        AddTrailingBackslash = ""
    ElseIf Right$(folderPath, 1) = "\" Then
        AddTrailingBackslash = folderPath
    Else
        AddTrailingBackslash = folderPath & "\"
    End If
End Function

Dim folderPath As String

folderPath = AddTrailingBackslash("C:\サンプル")
Debug.Print Dir(folderPath & "*.xlsx")

Option Explicit

Sub GetFirstFileName()
    Const FOLDER_PATH As String = "C:\サンプル\"

    Dim fileName As String

    fileName = Dir(FOLDER_PATH & "*.*")

    If fileName <> "" Then
        Worksheets("Sheet1").Range("A1").Value = fileName
    Else
        Worksheets("Sheet1").Range("A1").Value = "ファイルが見つかりません"
    End If
End Sub

Option Explicit

Sub ListAllNormalFiles()
    Const FOLDER_PATH As String = "C:\サンプル\"

    Dim ws As Worksheet
    Dim fileName As String
    Dim nextRow As Long

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    ws.Range("A:B").ClearContents
    ws.Range("A1").Value = "ファイル名"
    ws.Range("B1").Value = "フルパス"

    nextRow = 2
    fileName = Dir(FOLDER_PATH & "*.*")

    Do While fileName <> ""
        ws.Cells(nextRow, 1).Value = fileName
        ws.Cells(nextRow, 2).Value = FOLDER_PATH & fileName
        nextRow = nextRow + 1
        fileName = Dir()
    Loop
End Sub

Option Explicit

Sub ListFilesWithAttributes()
    Const FOLDER_PATH As String = "C:\サンプル\"

    Dim fileName As String
    Dim nextRow As Long

    nextRow = 2
    fileName = Dir(FOLDER_PATH & "*.*", vbHidden Or vbReadOnly)

    Do While fileName <> ""
        Worksheets("Sheet1").Cells(nextRow, 1).Value = fileName
        nextRow = nextRow + 1
        fileName = Dir()
    Loop
End Sub

Option Explicit

Sub ListXlsmFiles()
    Const FOLDER_PATH As String = "C:\サンプル\"

    Dim fileName As String
    Dim nextRow As Long

    nextRow = 2
    fileName = Dir(FOLDER_PATH & "*.xlsm")

    Do While fileName <> ""
        Worksheets("Sheet1").Cells(nextRow, 1).Value = fileName
        nextRow = nextRow + 1
        fileName = Dir()
    Loop
End Sub

Option Explicit

Sub OpenAllXlsxFiles()
    Const FOLDER_PATH As String = "C:\サンプル\"

    Dim fileName As String
    Dim wb As Workbook

    fileName = Dir(FOLDER_PATH & "*.xlsx")

    Do While fileName <> ""
        Set wb = Workbooks.Open(FOLDER_PATH & fileName)

        'ここにブックごとの処理を書く
        Debug.Print wb.Name

        wb.Close SaveChanges:=False
        fileName = Dir()
    Loop
End Sub

Option Explicit

Sub ListFilesWithHyperlinks()
    Const FOLDER_PATH As String = "C:\サンプル\"

    Dim ws As Worksheet
    Dim fileName As String
    Dim nextRow As Long
    Dim fullPath As String

    Set ws = ThisWorkbook.Worksheets("Sheet1")

    ws.Range("A:B").ClearContents
    ws.Range("A1").Value = "ファイル名"
    ws.Range("B1").Value = "フルパス"

    nextRow = 2
    fileName = Dir(FOLDER_PATH & "*.*", vbHidden Or vbReadOnly)

    Do While fileName <> ""
        fullPath = FOLDER_PATH & fileName

        ws.Hyperlinks.Add _
            Anchor:=ws.Cells(nextRow, 1), _
            Address:=fullPath, _
            TextToDisplay:=fileName

        ws.Cells(nextRow, 2).Value = fullPath

        nextRow = nextRow + 1
        fileName = Dir()
    Loop
End Sub

Option Explicit

Public Function FileExistsByDir(ByVal targetPath As String) As Boolean
    FileExistsByDir = (Len(Dir(targetPath)) > 0)
End Function

Sub CheckFileSample()
    If FileExistsByDir("C:\サンプル\売上.xlsx") Then
        MsgBox "ファイルがあります"
    Else
        MsgBox "ファイルがありません"
    End If
End Sub

Option Explicit

Public Function FolderExistsByGetAttr(ByVal folderPath As String) As Boolean
    On Error GoTo NotFound

    FolderExistsByGetAttr = ((GetAttr(folderPath) And vbDirectory) = vbDirectory)
    Exit Function

NotFound:
    FolderExistsByGetAttr = False
End Function

'このようなネストは避ける
folderName = Dir("C:\サンプル\*", vbDirectory)

Do While folderName <> ""
    If folderName <> "." And folderName <> ".." Then
        If (GetAttr("C:\サンプル\" & folderName) And vbDirectory) = vbDirectory Then
            fileName = Dir("C:\サンプル\" & folderName & "\*.xlsx")

            Do While fileName <> ""
                Debug.Print fileName
                fileName = Dir()
            Loop
        End If
    End If

    'ここで外側のDir検索状態が崩れている可能性がある
    folderName = Dir()
Loop

Option Explicit

Sub ListFilesRecursiveByFso()
    Const ROOT_FOLDER As String = "C:\サンプル"

    Dim fso As Object
    Dim rootFolder As Object
    Dim ws As Worksheet
    Dim nextRow As Long

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set rootFolder = fso.GetFolder(ROOT_FOLDER)
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    ws.Range("A:C").ClearContents
    ws.Range("A1").Value = "ファイル名"
    ws.Range("B1").Value = "フルパス"
    ws.Range("C1").Value = "親フォルダ"

    nextRow = 2
    WriteFilesInFolder rootFolder, ws, nextRow
End Sub

Private Sub WriteFilesInFolder(ByVal targetFolder As Object, _
                               ByVal ws As Worksheet, _
                               ByRef nextRow As Long)
    Dim fileItem As Object
    Dim subFolder As Object

    For Each fileItem In targetFolder.Files
        ws.Cells(nextRow, 1).Value = fileItem.Name
        ws.Cells(nextRow, 2).Value = fileItem.Path
        ws.Cells(nextRow, 3).Value = targetFolder.Path
        nextRow = nextRow + 1
    Next fileItem

    For Each subFolder In targetFolder.SubFolders
        WriteFilesInFolder subFolder, ws, nextRow
    Next subFolder
End Sub

Debug.Print FOLDER_PATH & "*.xlsx"
Debug.Print fileName