指定したフォルダ内のすべてのファイルの特定のプロパティを取得し、それをExcelシートに書き込む
このタイトルのマクロは、以下です。
Dim tbl() As Variant ' データを収納する配列
' 指定フォルダ内のすべてのファイルの特定のプロパティを取得
Sub sample()
' フォルダを指定
Dim folderName As String
folderName = "H:\music"
' 処理する拡張子を、配列に格納
Dim myArray As Variant
' 配列に値を設定
' "*"を設定した場合は、すべての拡張子に対応
myArray = Array("*")
' 指定したフォルダ内のファイルに対して、同じ処理をする
Call ProcessFilesInFolderIncludeExtension(folderName, myArray)
' 配列の行列変換
tbl = TransposeArray(tbl)
' 配列をシートへ書込み
Call シートへの書込
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
' "*"の場合、すべての拡張子を処理する
If myArray(0) = "*" Then
flg = True
Else
For i = LBound(myArray) To UBound(myArray)
If myArray(i) = extension Then
' 配列に含まれた場合
flg = True
Exit For
End If
Next i
End If
' 拡張子が配列に含まれた場合
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 propertyIndex As Long
propertyIndex = 27 '長さ
' 配列が空かどうか判断
If (Not tbl) = -1 Then
' 配列が空の時
ReDim Preserve tbl(1 To 2, 1 To 1)
Else
' 配列が空でないとき、1次元は変更不可、2次元を1つ拡大
ReDim Preserve tbl(1 To 2, 1 To UBound(tbl, 2) + 1)
End If
' ファイル名とプロパティを、配列に書込み
tbl(1, UBound(tbl, 2)) = file.Name
tbl(2, UBound(tbl, 2)) = getExtendedOneProperty(file.Path, propertyIndex)
End Sub
'**********************
'* ファイルの一つのプロパティを取得
'* aFilePath：ファイルのパス名
'* index：プロパティのIndex、12:撮影日時、27:長さ
Private Function getExtendedOneProperty(ByVal aFilePath As String, ByVal index As Long) As String
Dim rtnAry As String ' 返り値となるプロパティの値を格納する変数
Dim fso As Object
' FileSystemObjectを作成して遅延バインディング
Set fso = CreateObject("Scripting.FileSystemObject")
Dim sh As Object
' Shell.Applicationオブジェクトを作成して遅延バインディング
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))
' 指定されたインデックスのプロパティを取得
rtnAry = shFolder.GetDetailsOf(shFile, index)
' 取得したプロパティを返す
getExtendedOneProperty = rtnAry
' オブジェクトを解放
Set fso = Nothing
End Function
'**********************
'* 配列の行列変換
'* myArray：変換する配列
Private Function TransposeArray(ByVal myArray As Variant) As Variant
Dim x As Long, y As Long
Dim maxX As Long, minX As Long
Dim maxY As Long, minY As Long
Dim tempArr As Variant
'上限と下限を取得
maxX = UBound(myArray, 1)
minX = LBound(myArray, 1)
maxY = UBound(myArray, 2)
minY = LBound(myArray, 2)
'一時的な配列を作成する
ReDim tempArr(minY To maxY, minX To maxX)
'配列の行列変換
For x = minX To maxX
For y = minY To maxY
tempArr(y, x) = myArray(x, y)
Next y
Next x
'出力配列
TransposeArray = tempArr
End Function
'**********************
'* 配列をシートへ書込み
Private Sub シートへの書込()
Dim ws As Worksheet
' シート名を指定する
Dim newSheetName As String
newSheetName = "List"
If ExistSheet(newSheetName, 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(tbl, rng)
ThisWorkbook.Activate
ws.Activate
' 配列を初期化
Erase tbl
End Sub
'*************************
'* シートが存在しているかどうか確認する関数。存在する場合は、Trueを返す
'* shetName：調べたいシート名を指定
'* book：調べたいワークブックを指定
Private 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
'*******
'* 「二次元配列」を「シート」に入れるプロシージャ。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サブルーチンがメインの処理を実行します。- 指定したフォルダ内のファイルのプロパティを取得し、配列に格納します。
- 配列を行列変換し、シートに書き込みます。
以下に各部分の詳しい解説をします。
メインの処理: sample
Dim tbl() As Variant ' データを収納する配列
' 指定フォルダ内のすべてのファイルの特定のプロパティを取得
Sub sample()
' フォルダを指定
Dim folderName As String
folderName = "H:\music"
' 処理する拡張子を、配列に格納
Dim myArray As Variant
' 配列に値を設定
' "*"を設定した場合は、すべての拡張子に対応
myArray = Array("*")
' 指定したフォルダ内のファイルに対して、同じ処理をする
Call ProcessFilesInFolderIncludeExtension(folderName, myArray)
' 配列の行列変換
tbl = TransposeArray(tbl)
' 配列をシートへ書込み
Call シートへの書込
End SubfolderNameにはプロパティを取得する対象のフォルダを指定します。myArrayには処理するファイルの拡張子を指定します。ここではすべてのファイルを処理するために"*"を設定しています。ProcessFilesInFolderIncludeExtensionを呼び出し、フォルダ内のファイルを処理します。TransposeArrayで配列を行列変換します。シートへの書込を呼び出し、配列の内容をExcelシートに書き込みます。
フォルダ内のファイルを処理する: ProcessFilesInFolderIncludeExtension
'**********************************
'* 指定したフォルダ内のファイルに対して、同じ処理をする
'* 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
' "*"の場合、すべての拡張子を処理する
If myArray(0) = "*" Then
flg = True
Else
For i = LBound(myArray) To UBound(myArray)
If myArray(i) = extension Then
' 配列に含まれた場合
flg = True
Exit For
End If
Next i
End If
' 拡張子が配列に含まれた場合
If flg Then
' 必要な処理を実行
Call ProcessFile(file)
End If
Next file
Set fso = Nothing
End SubFileSystemObjectを使ってフォルダ内のファイルを取得します。- 各ファイルの拡張子を確認し、指定した拡張子と一致する場合に処理を行います。今回は、
Array(0) = "*"としたので、すべての拡張子を処理しています。 ProcessmyFileを呼び出して各ファイルのプロパティを取得し、配列に格納します。
各ファイルのプロパティを取得する: ProcessFile
'**********************************
'* 各ファイルに対する処理を追加
'* file：Fileオブジェクト
Private Sub ProcessFile(ByRef file As Object)
' 取得するプロパティインデックスを指定
Dim propertyIndex As Long
propertyIndex = 27 '長さ
' 配列が空かどうか判断
If (Not tbl) = -1 Then
' 配列が空の時
ReDim Preserve tbl(1 To 2, 1 To 1)
Else
' 配列が空でないとき、1次元は変更不可、2次元を1つ拡大
ReDim Preserve tbl(1 To 2, 1 To UBound(tbl, 2) + 1)
End If
' ファイル名とプロパティを、配列に書込み
tbl(1, UBound(tbl, 2)) = file.Name
tbl(2, UBound(tbl, 2)) = getExtendedOneProperty(file.Path, propertyIndex)
End SubpropertyIndexで取得するプロパティを指定します。ここでは27（長さ）を取得します。- 配列
tblが空かどうかを確認し、空の場合は新たに初期化します。空でない場合は既存の配列を拡張します。 - ファイル名とプロパティの値を配列
tblに格納します。
プロパティを取得する: getExtendedOneProperty
'**********************
'* ファイルの一つのプロパティを取得
'* aFilePath：ファイルのパス名
'* index：プロパティのIndex、12:撮影日時、27:長さ
Private Function getExtendedOneProperty(ByVal aFilePath As String, ByVal index As Long) As String
Dim rtnAry As String ' 返り値となるプロパティの値を格納する変数
Dim fso As Object
' FileSystemObjectを作成して遅延バインディング
Set fso = CreateObject("Scripting.FileSystemObject")
Dim sh As Object
' Shell.Applicationオブジェクトを作成して遅延バインディング
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))
' 指定されたインデックスのプロパティを取得
rtnAry = shFolder.GetDetailsOf(shFile, index)
' 取得したプロパティを返す
getExtendedOneProperty = rtnAry
' オブジェクトを解放
Set fso = Nothing
End FunctionFileSystemObjectとShell.Applicationを使ってファイルのプロパティを取得します。- 指定したインデックスのプロパティを取得し、返り値として返します。
配列の行列変換: TransposeArray
'**********************
'* 配列の行列変換
'* myArray：変換する配列
Private Function TransposeArray(ByVal myArray As Variant) As Variant
Dim x As Long, y As Long
Dim maxX As Long, minX As Long
Dim maxY As Long, minY As Long
Dim tempArr As Variant
'上限と下限を取得
maxX = UBound(myArray, 1)
minX = LBound(myArray, 1)
maxY = UBound(myArray, 2)
minY = LBound(myArray, 2)
'一時的な配列を作成する
ReDim tempArr(minY To maxY, minX To maxX)
'配列の行列変換
For x = minX To maxX
For y = minY To maxY
tempArr(y, x) = myArray(x, y)
Next y
Next x
'出力配列
TransposeArray = tempArr
End Function- 指定された配列
myArrayの行列を入れ替えた新しい配列を作成します。 - 入れ替えた配列を返します。
詳細は、以下を参考にしてください。
配列をシートへ書き込む: シートへの書込
'**********************
'* 配列をシートへ書込み
Private Sub シートへの書込()
Dim ws As Worksheet
' シート名を指定する
Dim newSheetName As String
newSheetName = "List"
If ExistSheet(newSheetName, 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(tbl, rng)
ThisWorkbook.Activate
ws.Activate
' 配列を初期化
Erase tbl
End SubThisWorkbook.Activateとws.Activateで、書き込んだシートをアクティブにします。- 最後に
Erase tblで配列tblを初期化します。これにより、次回の処理の際に前回のデータが残らないようにします。
シートが存在するかどうか確認する: ExistSheet
'*************************
'* シートが存在しているかどうか確認する関数。存在する場合は、Trueを返す
'* shetName：調べたいシート名を指定
'* book：調べたいワークブックを指定
Private 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 FunctionExistSheet関数は指定したシート名が存在するかどうかを確認します。- ワークブック内のすべてのワークシートをループし、シート名を比較します。
- シート名が一致した場合、
flagをTrueに設定し、最後にその値を返します。
詳細は、以下を参照してください。
配列をシートに書き込む: 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 Subarray_to_sheetサブルーチンは、二次元配列myArrayを指定されたレンジFirstRangeに書き込みます。Resizeメソッドを使用して、FirstRangeのサイズをmyArrayのサイズに合わせて調整し、配列の内容をシートに書き込みます。
詳細は、以下を参照してください。
マクロ全体のフロー
sampleサブルーチンが開始されます。- 指定されたフォルダ内のすべてのファイルに対して
ProcessFilesInFolderIncludeExtensionを実行し、各ファイルの特定のプロパティを取得します。 - 取得したプロパティを配列
tblに格納します。 - 配列
tblをTransposeArrayで行列変換します。 シートへの書込を実行し、変換された配列を指定されたシートに書き込みます。
このマクロは、特定のフォルダ内のファイルのプロパティを収集し、それをExcelシートに効率よく書き込むことを目的としています。主に音楽ファイルのプロパティを収集するために使用されることが想定されていますが、拡張子やプロパティインデックスを変更することで他の用途にも応用可能です。
このマクロは、以下のマクロをかなり流用しています。
Follow me!
