| |
はじめましてこんばんは。
仕事の必要上、「サブフォルダを含めた全フォルダの中の、全ファイルのプロパティ(詳細情報)の一覧作成」マクロを、vbaの知識がないことからweb上の作例を参考に作ろうとしているのですが、全くうまく動きません。
大変お恥ずかしいのですが、下の記述で修正個所等を教えてください。
よろしくお願いします。
Sub ファイルプロパティ一覧()
Dim フォルダパス As String
Dim ファイルタイプ As String
Dim エラーカウント As Integer
Dim 拡張子 As String
Dim メッセージ As String
Dim 開始日時 As Variant
Dim 終了日時 As Variant
Dim 既存データ As Integer
Dim 追加シート名初期 As String
Dim 追加シート名 As String
Dim 重複 As Integer
Dim シート As Worksheet
Dim シート数 As Integer
追加シート名初期 = "ファイプロパティ"
追加シート名 = 追加シート名初期
ThisWorkbook.Worksheets("スタートシート").Activate
For 重複 = 1 To 100
For Each シート In Worksheets
If シート.Name = 追加シート名 Then
追加シート名 = 追加シート名初期 & "(" & 重複 & ")"
End If
Next シート
Next 重複
シート数 = Worksheets.Count
Worksheets("テンプレート02").Copy After:=Worksheets(シート数)
ActiveSheet.Name = 追加シート名
ChDrive ThisWorkbook.Path
ChDir ThisWorkbook.Path
フォルダパス = Application.GetOpenFilename(ファイルタイプ)
If フォルダパス = "False" Then End
開始日時 = Now ' 開始時刻を変数に格納
フォルダパス = Left(フォルダパス, InStrRev(フォルダパス, "\"))
On Error GoTo エラー表示
項目数 = 40
ReDim ファイルプロパティ(項目数, 1)
Call ファイル検索(フォルダパス, ファイルプロパティ, 拡張子)
Worksheets(追加シート名).Activate
Range("A3").Resize(UBound(ファイルプロパティ, 2), 項目数) _
= WorksheetFunction.Transpose(ファイルプロパティ)
Range("A3").Select
終了日時 = Now
MsgBox "処理時間は、" _
& Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"
Exit Sub 'エラー以外は、以下のラベル部分を実行させないためのテクニック。
エラー表示:
エラーカウント = エラーカウント + 1
メッセージ = "エラーが発生しました。" & Chr(13) _
& "フォルダパス= " & フォルダパス & Chr(13) _
& "フルパス= " & フルパス & Chr(13) _
& "UBound(ファイルプロパティ, 2)= " & UBound(ファイルプロパティ, 2) & Chr(13) _
& "ActiveWorkbook名= " & ActiveWorkbook.Name & Chr(13) _
& "エラー番号 " & Str(Err.Number) & Err.Source & _
" でエラーが発生しました。" & Chr(13) & Err.Description
MsgBox メッセージ, , "エラー", Err.HelpFile, Err.HelpContext
ActiveWorkbook.Close False
If エラーカウント > 5 Then Exit Sub
Resume Next
End Sub
Sub ファイル検索(フォルダパス As String, ファイルプロパティ() As String, 拡張子 As String)
'再帰処理でファイル抽出
Dim i As Integer
Dim strFileName As Variant
Dim 行 As Integer
Dim 列 As Integer
Dim ファイル As Integer
Dim データ(10000, 65) As Variant
Dim 追加シート名 As String
Dim ファイル拡張子 As String
Dim ファイル名 As String
Dim objShell As Object
Dim objFolder As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(フォルダパス)
For i = 0 To 40
データ(0, i) = objFolder.GetDetailsOf(objFolder.Items, i)
Next
ファイル = 0
For Each strFileName In objFolder.Items
ファイル名 = CStr(strFileName)
ファイル拡張子 = LCase(Right(ファイル名, Len(ファイル名) - InStrRev(ファイル名, ".")))
If 拡張子 = "*" Then ファイル拡張子 = "*"
If ファイル拡張子 = 拡張子 Then
ファイル = ファイル + 1
For i = 0 To 40
データ(ファイル, i) = objFolder.GetDetailsOf(strFileName, i)
Next
End If
Next
ThisWorkbook.Worksheets(追加シート名).Activate
Application.ScreenUpdating = True
For 行 = 0 To ファイル
For 列 = 0 To 40
ThisWorkbook.Worksheets(追加シート名).Range("A2").Cells(行 + 1, 列 + 1) _
= データ(行, 列)
Next 列
Next 行
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
