2024年5月20日 / 最終更新日時 : 2024年5月23日 alljapan Excel

指定したフォルダ内の特定の拡張子を持つファイルを処理するマクロ

このマクロは、指定したフォルダ内の特定の拡張子を持つファイルを処理し、それらのファイルのプロパティを取得して、Excelシートに表示する一連の操作を行います。全体は、以下です。

' 指定フォルダ内の特定の拡張子のプロパティを取得する
Sub sample()
    Dim folderName As String
    folderName = "H:\temp"
    
    ' 処理する拡張子を、配列に格納
    Dim myArray As Variant
    ' 配列に値を設定
    myArray = Array("wav", "jpeg")

    
    Call ProcessFilesInFolderIncludeExtension(folderName, myArray)

End Sub

'**********************************
'* 指定したフォルダ内のファイルに対して、同じ処理をする
'* folderPath：フォルダパス名
'* myArray：拡張子の入った配列。この配列で指定した拡張子のみ処理する。
Private Sub ProcessFilesInFolderIncludeExtension(ByVal folderPath As String, ByRef myArray As Variant)
    Dim fso As Object
    Dim file As Object
    
    ' FileSystemObjectを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' フォルダ内の各ファイルに対して処理
    For Each file In fso.GetFolder(folderPath).Files
        ' ファイルの拡張子を取得
        Dim extension As String
        extension = fso.GetExtensionName(file.Name)
        
        ' ファイルの拡張子が配列に含まれるかどうか
        Dim flg As Boolean: flg = False
        Dim i As Long
        For i = LBound(myArray) To UBound(myArray)
            If myArray(i) = extension Then
                ' 配列に含まれた場合
                flg = True
                Exit For
            End If
        Next i
    
        ' 拡張子が配列に含まれた場合
        If flg Then
            ' 必要な処理を実行
            Call ProcessFile(file)
        End If
    Next file
    
    Set fso = Nothing
End Sub

'**********************************
'* 各ファイルに対する処理を追加
'* file：Fileオブジェクト
Private Sub ProcessFile(ByRef file As Object)

     ' 全てのプロパティを取得する関数
     Dim s As Variant
     s = getExtendedProperty(file.Path)
     
     Dim ws As Worksheet
     
     ' ファイル名をシート名にする
     Dim newSheetName As String
     newSheetName = file.Name
     
     If ExistSheet(file.Name, ThisWorkbook) Then
        ' シート名があれば、クリア
        Set ws = Worksheets(newSheetName)
        ws.Cells.Clear
     Else
        ' シート名がなければ
        ' 現在あるワークシートの最後尾に新規シート作成
        Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        ws.Name = newSheetName
     End If
     
     ' 新規シートのセルA1
     Dim rng As Range
     Set rng = ws.Range("A1")
     
     ' 「二次元配列」を「シート」に入れる
     Call array_to_sheet(s, rng)
End Sub

'*************************
'* シートが存在しているかどうか確認する関数。存在する場合は、Trueを返す
'* shetName：調べたいシート名を指定
'* book：調べたいワークブックを指定
Function ExistSheet(ByVal sheetName As String, ByVal book As Workbook) As Boolean
    Dim ws As Worksheet, flag As Boolean
    ' すべてのワークシートを表す Worksheets コレクションからひとつずつ
    ' Worksheetを取り出して、名前を確認します。
    For Each ws In book.Worksheets
        If ws.Name = sheetName Then flag = True
    Next ws
    
    ExistSheet = flag
End Function

'*************************
'* 全てのプロパティを取得する関数
'* aFilePath：ファイルパス名
'* 無条件で500までの配列で返します
Private Function getExtendedProperty(ByVal aFilePath As String) As Variant()
    Dim rtnAry() As Variant
    ReDim rtnAry(1 To 500, 1 To 2)
  
    Dim fso As Object
    ' 遅延バインディング（実行時バインディング）
    Set fso = CreateObject("Scripting.FileSystemObject")
  
    Dim sh As Object
    ' 遅延バインディング（実行時バインディング）
    Set sh = CreateObject("Shell.Application")
    Dim shFolder As Object
    Dim shFile As Object
    Set shFolder = sh.Namespace(fso.GetParentFolderName(aFilePath))

    Dim i As Long
    Set shFile = shFolder.ParseName(fso.GetFileName(aFilePath))
    '以下でも良い
    'Set shFile = shFolder.Items.Item(fso.GetFileName(aFilePath))
    
    ' Folder.GetDetailsOfメソッド
    ' フォルダー内のアイテムに関する詳細を取得します｡
    ' 取得する情報を指定する整数値を引数に指定します｡
    For i = 1 To 500
        rtnAry(i, 1) = shFolder.GetDetailsOf(Nothing, i)
        rtnAry(i, 2) = shFolder.GetDetailsOf(shFile, i)
    Next
    getExtendedProperty = rtnAry
End Function

'*******
'* 「二次元配列」を「シート」に入れるプロシージャ。20230707
'* SheetName：シート名前
'* myArray：二次元配列。参照渡し。配列は、モジュールレベル変数としている。
'* FirstRange：配列を入れる先頭のRange
Private Sub array_to_sheet(ByRef myArray As Variant, ByVal FirstRange As Range)
    FirstRange.Resize(UBound(myArray), UBound(myArray, 2)) = myArray
End Sub

以下に、各部分の詳細な説明をします。

sample サブルーチン

このサブルーチンは、処理のエントリーポイントです。フォルダ名と処理するファイルの拡張子を指定し、それらを ProcessFilesInFolderIncludeExtension サブルーチンに渡します。

' 指定フォルダ内の特定の拡張子のプロパティを取得する
Sub sample()
    Dim folderName As String
    folderName = "H:\temp"
    
    ' 処理する拡張子を、配列に格納
    Dim myArray As Variant
    ' 配列に値を設定
    myArray = Array("wav", "jpeg")

    
    Call ProcessFilesInFolderIncludeExtension(folderName, myArray)

End Sub

ProcessFilesInFolderIncludeExtension サブルーチン

このサブルーチンは、指定されたフォルダ内のファイルをチェックし、指定された拡張子を持つファイルに対して ProcessFile サブルーチンを実行します。

'**********************************
'* 指定したフォルダ内のファイルに対して、同じ処理をする
'* folderPath：フォルダパス名
'* myArray：拡張子の入った配列。この配列で指定した拡張子のみ処理する。
Private Sub ProcessFilesInFolderIncludeExtension(ByVal folderPath As String, ByRef myArray As Variant)
    Dim fso As Object
    Dim file As Object
    
    ' FileSystemObjectを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' フォルダ内の各ファイルに対して処理
    For Each file In fso.GetFolder(folderPath).Files
        ' ファイルの拡張子を取得
        Dim extension As String
        extension = fso.GetExtensionName(file.Name)
        
        ' ファイルの拡張子が配列に含まれるかどうか
        Dim flg As Boolean: flg = False
        Dim i As Long
        For i = LBound(myArray) To UBound(myArray)
            If myArray(i) = extension Then
                ' 配列に含まれた場合
                flg = True
                Exit For
            End If
        Next i
    
        ' 拡張子が配列に含まれた場合
        If flg Then
            ' 必要な処理を実行
            Call ProcessFile(file)
        End If
    Next file
    
    Set fso = Nothing
End Sub
  1. FileSystemObjectの作成:
    • Set fso = CreateObject("Scripting.FileSystemObject") により、ファイルシステム操作を行うためのオブジェクトを作成します。
  2. フォルダ内のファイルをループ処理:
    • For Each file In fso.GetFolder(folderPath).Files で、指定フォルダ内のすべてのファイルをループします。
  3. ファイルの拡張子を取得:
    • extension = fso.GetExtensionName(file.Name) により、各ファイルの拡張子を取得します。
  4. 拡張子のチェック:
    • For i = LBound(myArray) To UBound(myArray) で、指定された拡張子の配列をループし、ファイルの拡張子が配列に含まれているかをチェックします。
    • 含まれている場合、flg を True に設定し、ループを抜けます。
  5. ファイルの処理:
    • 拡張子が配列に含まれている場合 (If flg Then)、そのファイルに対して ProcessFile サブルーチンを呼び出します。

ProcessFile サブルーチン

このサブルーチンは、特定のファイルに対して処理を行います。ファイルのプロパティを取得し、その情報を新しいシートに書き込みます。

'**********************************
'* 各ファイルに対する処理を追加
'* file：Fileオブジェクト
Private Sub ProcessFile(ByRef file As Object)

     ' 全てのプロパティを取得する関数
     Dim s As Variant
     s = getExtendedProperty(file.Path)
     
     Dim ws As Worksheet
     
     ' ファイル名をシート名にする
     Dim newSheetName As String
     newSheetName = file.Name
     
     If ExistSheet(file.Name, ThisWorkbook) Then
        ' シート名があれば、クリア
        Set ws = Worksheets(newSheetName)
        ws.Cells.Clear
     Else
        ' シート名がなければ
        ' 現在あるワークシートの最後尾に新規シート作成
        Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        ws.Name = newSheetName
     End If
     
     ' 新規シートのセルA1
     Dim rng As Range
     Set rng = ws.Range("A1")
     
     ' 「二次元配列」を「シート」に入れる
     Call array_to_sheet(s, rng)
End Sub
  1. プロパティの取得:
    • s = getExtendedProperty(file.Path) で、ファイルの拡張プロパティを取得し、配列に格納します。
  2. シート名の設定:
    • newSheetName = file.Name により、ファイル名を新しいシートの名前として設定します。
  3. シートの存在確認:
    • If ExistSheet(file.Name, ThisWorkbook) Then により、シートが既に存在するかどうかを確認します。
    • 存在する場合はシートをクリアし (ws.Cells.Clear)、存在しない場合は新しいシートを追加します (Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count)))。
  4. プロパティの書き込み:
    • Set rng = ws.Range("A1") により、書き込み先のセル範囲を設定します。
    • Call array_to_sheet(s, rng) で、取得したプロパティをシートに書き込みます。

ExistSheet 関数

この関数は、指定したシート名が既に存在するかどうかを確認し、存在する場合は True を返します。

'*************************
'* シートが存在しているかどうか確認する関数。存在する場合は、Trueを返す
'* shetName：調べたいシート名を指定
'* book：調べたいワークブックを指定
Function ExistSheet(ByVal sheetName As String, ByVal book As Workbook) As Boolean
    Dim ws As Worksheet, flag As Boolean
    ' すべてのワークシートを表す Worksheets コレクションからひとつずつ
    ' Worksheetを取り出して、名前を確認します。
    For Each ws In book.Worksheets
        If ws.Name = sheetName Then flag = True
    Next ws
    
    ExistSheet = flag
End Function

この関数は、以下を参照してください。

シートが存在しているかどうか確認する関数。

getExtendedProperty 関数

この関数は、指定されたファイルの詳細なプロパティを取得し、500行x2列の配列として返します。

'*************************
'* 全てのプロパティを取得する関数
'* aFilePath：ファイルパス名
'* 無条件で500までの配列で返します
Private Function getExtendedProperty(ByVal aFilePath As String) As Variant()
    Dim rtnAry() As Variant
    ReDim rtnAry(1 To 500, 1 To 2)
  
    Dim fso As Object
    ' 遅延バインディング（実行時バインディング）
    Set fso = CreateObject("Scripting.FileSystemObject")
  
    Dim sh As Object
    ' 遅延バインディング（実行時バインディング）
    Set sh = CreateObject("Shell.Application")
    Dim shFolder As Object
    Dim shFile As Object
    Set shFolder = sh.Namespace(fso.GetParentFolderName(aFilePath))

    Dim i As Long
    Set shFile = shFolder.ParseName(fso.GetFileName(aFilePath))
    '以下でも良い
    'Set shFile = shFolder.Items.Item(fso.GetFileName(aFilePath))
    
    ' Folder.GetDetailsOfメソッド
    ' フォルダー内のアイテムに関する詳細を取得します｡
    ' 取得する情報を指定する整数値を引数に指定します｡
    For i = 1 To 500
        rtnAry(i, 1) = shFolder.GetDetailsOf(Nothing, i)
        rtnAry(i, 2) = shFolder.GetDetailsOf(shFile, i)
    Next
    getExtendedProperty = rtnAry
End Function

この関数は、以下を参照してください。

ファイルの全てのプロパティを取得する関数

array_to_sheet サブルーチン

このサブルーチンは、二次元配列の内容を指定したセル範囲に書き込みます。

'*******
'* 「二次元配列」を「シート」に入れるプロシージャ。20230707
'* SheetName：シート名前
'* myArray：二次元配列。参照渡し。配列は、モジュールレベル変数としている。
'* FirstRange：配列を入れる先頭のRange
Private Sub array_to_sheet(ByRef myArray As Variant, ByVal FirstRange As Range)
    FirstRange.Resize(UBound(myArray), UBound(myArray, 2)) = myArray
End Sub

この関数は、以下を参照してください。

「二次元配列」を「シート」に入れる

全体の流れのまとめ

  1. sample サブルーチンが呼び出され、指定されたフォルダ内の特定の拡張子を持つファイルを処理します。
  2. ProcessFilesInFolderIncludeExtension サブルーチンが、フォルダ内のファイルをチェックし、指定された拡張子に一致するファイルに対して ProcessFile サブルーチンを呼び出します。
  3. ProcessFile サブルーチンが、各ファイルのプロパティを取得し、新しいシートにその情報を書き込みます。
  4. ExistSheet 関数が、シートが既に存在するかを確認し、存在すればクリアし、存在しなければ新規にシートを作成します。
  5. getExtendedProperty 関数が、ファイルの詳細プロパティを取得し、配列として返します。
  6. array_to_sheet サブルーチンが、取得したプロパティをシートに書き込みます。

このマクロは、フォルダ内の特定の拡張子を持つファイルの詳細プロパティを取得し、それらをExcelシートに整理するための非常に有用なツールです。

このマクロは、以下のマクロをかなり流用しています。

指定したフォルダ内のすべてのファイルの特定のプロパティを取得し、それをExcelシートに書き込む

Follow me!

カテゴリー
Excel、FSO、VBA、マクロ、配列、関数
Excel

前の記事

ファイルの全てのプロパティを取得する関数
2024年5月19日
Excel

次の記事

Excelの設定を一時的に変更することで、マクロの実行速度を向上
2024年5月22日