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 質問[未読]
【76334】Re:「サブフォルダ内ファイルのプロパティ... マルチネス 14/11/1(土) 7:42 発言[未読]
【76335】Re:「サブフォルダ内ファイルのプロパティ... おさむ 14/11/1(土) 9:42 お礼[未読]
【76342】Re:「サブフォルダ内ファイルのプロパティ... カリーニン 14/11/1(土) 20:39 発言[未読]
【76345】Re:「サブフォルダ内ファイルのプロパティ... おさむ 14/11/1(土) 21:51 回答[未読]
【76349】Re:「サブフォルダ内ファイルのプロパティ... カリーニン 14/11/1(土) 23:24 発言[未読]
【76350】Re:「サブフォルダ内ファイルのプロパティ... おさむ 14/11/1(土) 23:30 お礼[未読]
【76378】Re:「サブフォルダ内ファイルのプロパティ... 渡辺真 14/11/10(月) 10:52 回答[未読]

6002 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free