Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

6002 / 76732

←次へ　｜　前へ→


	【76333】「サブフォルダ内ファイルのプロパティ取得」について

おさむ - 14/11/1(土) 1:52 -


	引用なし

	パスワード

はじめましてこんばんは。
仕事の必要上、「サブフォルダを含めた全フォルダの中の、全ファイルのプロパティ(詳細情報)の一覧作成」マクロを、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

3 hits

▼

【76333】「サブフォルダ内ファイルのプロパティ取得」について おさむ 14/11/1(土) 1:52