初めての投稿者ですが、このサイトで VBA と SQL のソリューションを見つけた長年のファンです。ユーザーが指定したディレクトリ内のすべての PDF ファイルを検索するように設計された VBA サブルーチンがあります。プログラムはすべてのサブフォルダーを再帰的に処理し、次のようにスプレッドシートを生成します。
列 A: 完全なファイル パス (「C:\Users\Records\NumberOne.pdf」)
列 B: ファイルを含むフォルダー パス ("C:\Users\Records\")
列 C: ファイル名自体 ("NumberOne.pdf")
この時点まで、プログラム (以下のコード) は問題なく動作します。これを使用して、50,000 を超える PDF ファイルを含むディレクトリを検索しましたが、毎回正常にスプレッドシートが生成されました (プログラムの合計経過時間は、通常、大きなディレクトリで 5 ～ 10 分です)。
問題は、列 D を追加して、PDF ファイルが作成された日付をキャプチャすることです。私はこれを Google で検索し、FSO.DateCreated などの手法を試して何時間も作業しましたが、何も機能しませんでした。FSO.DateCreated が必要な場合、それを機能させるためにサブルーチンのどこに挿入すればよいかわかりません。通常、オブジェクトがそのプロパティまたはメソッドをサポートしていないというエラーが表示されます。各 PDF が作成された日付を見つけて、出力スプレッドシートの列 D にドロップするためのプログラムの適切なコードを挿入できる場所を知っている人はいますか?
Sub GetFiles()
'-- RUNS AN UNLIMITED RECURSION SEARCH THROUGH A TARGETED FOLDER AND FINDS ALL PDF FILES WITHIN
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim j As Long
Dim ThisEntry As String
Dim strDir As String
Dim FSO As Object
Dim strFolder As String
Dim strName As String
Dim DateCreated As Date '--(Possibly String?)
Dim strArr(1 To 1048576, 1 To 1) As String, i As Long
Dim fldr As FileDialog
'-- OPEN DIALOG BOX TO SELECT DIRECTORY THE USER WISHES TO SEARCH
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select the directory you wish to search"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
Set fldr = Nothing
Else
strDir = .SelectedItems(1) & "\"
End If
End With
'-- LOOK FOR RECORDS WORKSHEET; IF IT DOES NOT EXIST, CREATE IT; IF IT DOES EXIST, CLEAR CONTENTS
If Not (wsExists("records")) Then
Worksheets.Add
With ActiveSheet
.Name = "records"
End With
Set ws = ActiveSheet
Else
Sheets("records").Activate
Range("A1:IV1").EntireColumn.Delete
Set ws = ActiveSheet
End If
'-- SET SEARCH PARAMETERS
Let strName = Dir$(strDir & "\" & "*.pdf")
Do While strName <> vbNullString
Let i = i + 1
Let strArr(i, 1) = strDir & strName
Let strName = Dir$()
Loop
'-- UNLIMITED RECURSIONS THROUGH SUBFOLDERS
Set FSO = CreateObject("Scripting.FileSystemObject")
Call recurseSubFolders(FSO.GetFolder(strDir), strArr(), i)
Set FSO = Nothing
'-- CREATE COLUMN HEADERS ON OUTPUT WORKSHEET
With ws
Range("A1").Value = "AbsolutePath"
Range("B1").Value = "FolderPath"
Range("C1").Value = "FileName"
Range("D1").Value = "DateCreated"
End With
If i > 0 Then
ws.Range("A2").Resize(i).Value = strArr
End If
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lr
ThisEntry = Cells(i, 1)
'-- EXTRACT FOLDER PATH AND FILE NAME FROM STRING
For j = Len(ThisEntry) To 1 Step -1
If Mid(ThisEntry, j, 1) = Application.PathSeparator Then
Cells(i, 2) = Left(ThisEntry, j)
Cells(i, 3) = Mid(ThisEntry, j + 1)
Exit For
End If
Next j
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
----------
Private Sub recurseSubFolders(ByRef Folder As Object, _
ByRef strArr() As String, _
ByRef i As Long)
Dim SubFolder As Object
Dim strName As String
For Each SubFolder In Folder.SubFolders
Let strName = Dir$(SubFolder.Path & "\" & "*.pdf")
Do While strName <> vbNullString
Let i = i + 1
Let strArr(i, 1) = SubFolder.Path & "\" & strName
Let strName = Dir$()
Loop
Call recurseSubFolders(SubFolder, strArr(), i)
Next
End Sub