エクセルでサイズ名の一覧を出したい

このQ&Aのポイント
  • エクセルでサイズ名の一覧を作成する方法について教えてください。
  • 現在、エクセルでフォルダ内のデータベースを作成しています。しかし、ファイルのサイズを一覧に加える方法がわかりません。
  • エクセルでファイルのサイズを一覧に追加する手順をご教示ください。
回答を見る
  • ベストアンサー

エクセルでサイズ名の一覧を出したい

現在、下記のコードでフォルダ内のデータベースを作成しています。 これに、『ファイルのサイズ』を加えたいのですが、何処に何を入れれば良いかがよくわかりません。 どなたか回答出来る方がいらっしゃれば、宜しくお願いします。 《現在使用しているコード》 Sub MakeFileList() Target = InputBox("ディレクトリ名を入力", "ディレクトリの指定", "C:\Windows") Set FS = CreateObject("Scripting.FileSystemObject") Set Fol = FS.GetFolder(Target) Set Fil = Fol.Files ThisWorkbook.Sheets("一覧").UsedRange.Delete '見出しを付ける ThisWorkbook.Sheets(1).Range("B2") = "ファイル名" ThisWorkbook.Sheets(1).Range("C2") = "ファイル種別" ThisWorkbook.Sheets(1).Range("D2") = "最終更新日" ThisWorkbook.Sheets(1).Range("E2") = "説明" ThisWorkbook.Sheets(1).Range("B2:E2").Interior.Color = RGB(0, 0, 0) ThisWorkbook.Sheets(1).Range("B2:E2").Font.Color = RGB(255, 255, 255) ThisWorkbook.Sheets(1).Range("B2:Es2").HorizontalAlignment = xlCenter i = 3 For Each Fx In Fil 'ファイル名 sFile = Fx.Name 'ファイル名の書き出し ThisWorkbook.Sheets(1).Cells(i, 2) = sFile 'ファイル種別 sFType = Fx.Type '最終更新日時の書き出し ThisWorkbook.Sheets(1).Cells(i, 3) = sFType '最終更新日 sLMod = Fx.DateLastModified ThisWorkbook.Sheets(1).Cells(i, 4) = sLMod i = i + 1 Next End Sub

質問者が選んだベストアンサー

  • ベストアンサー
  • mu2011
  • ベストアンサー率38% (1910/4994)
回答No.2

一例です。 名前の直後に挿入してみました。(若干、ソースを変更しました) Sub MakeFileList() Target = InputBox("ディレクトリ名を入力", "ディレクトリの指定", "C:\Windows") Set FS = CreateObject("Scripting.FileSystemObject") Set Fil = FS.GetFolder(Target).Files '見出しを付ける With ThisWorkbook.Sheets(1) .Range("B2") = "名前" .Range("C2") = "サイズ" .Range("D2") = "種別" .Range("E2") = "最終更新日" .Range("F2") = "説明" .Range("B2:F2").Interior.Color = RGB(0, 0, 0) .Range("B2:F2").Font.Color = RGB(255, 255, 255) .Range("B2:F2").HorizontalAlignment = xlCenter i = 3 For Each Fx In Fil .Cells(i, 2) = Fx.Name '名前 .Cells(i, 3).NumberFormatLocal = "#,##0"" KB""" .Cells(i, 3) = Fx.Size 'サイズ .Cells(i, 4) = Fx.Type '種別 .Cells(i, 5) = Fx.DateLastModified '最終更新日 i = i + 1 Next End With End Sub

nekotomi
質問者

お礼

お忙しい中ありがとうございます。 無事に解決出来ました。

その他の回答 (1)

  • MackyNo1
  • ベストアンサー率53% (1521/2850)
回答No.1

ファイルのサイズはSizeのプロパティで取得できます。 以下のページを参考にしてご自分でコードを作成してください。 http://officetanaka.net/excel/vba/filesystemobject/file.htm

関連するQ&A

  • フォルダ名をだすには

    以下のコードでファイル名一覧がだせる。しかしフォルダ名がでない フォルダ名をだすには、どうすればいいか。  sub macro1() Target = InputBox("ディレクトリ名を入力", "ディレクトリの指定", "C:\Windows") Set FS = CreateObject("Scripting.FileSystemObject") Set Fol = FS.GetFolder(Target) Set Fil = Fol.Files ThisWorkbook.Sheets("Sheet1").UsedRange.Delete '見出しを付ける ThisWorkbook.Sheets(1).Range("B2") = "ファイル名" ThisWorkbook.Sheets(1).Range("C2") = "ファイル種別" ThisWorkbook.Sheets(1).Range("D2") = "最終更新日" ThisWorkbook.Sheets(1).Range("E2") = "説明" ThisWorkbook.Sheets(1).Range("B2:E2").Interior.Color = RGB(0, 0, 0) ThisWorkbook.Sheets(1).Range("B2:E2").Font.Color = RGB(255, 255, 255) ThisWorkbook.Sheets(1).Range("B2:Es2").HorizontalAlignment = xlCenter i = 3 For Each Fx In Fil 'ファイル名 sFile = Fx.Name 'ファイル名の書き出し ThisWorkbook.Sheets(1).Cells(i, 2) = sFile 'ファイル種別 sFType = Fx.Type '最終更新日時の書き出し ThisWorkbook.Sheets(1).Cells(i, 3) = sFType '最終更新日 sLMod = Fx.DateLastModified ThisWorkbook.Sheets(1).Cells(i, 4) = sLMod i = i + 1 Next End Sub

  • ファイルの一覧を作成する

    お世話になります。 ファイルの一覧を作成するマクロを作っていますが、 拡張子を表示させないようにしたいのですが ”オブジェクトが必要です”と エラー出てなかなかうまくいきません。 どなたか助けてください。 Sub MakeFileList() Target = InputBox("ディレクトリ名を入力", "ディレクトリの指定", "C:\Windows") Set FS = CreateObject("Scripting.FileSystemObject") Set Fol = FS.GetFolder(Target) Set Fil = Fol.Files ThisWorkbook.Sheets("Sheet1").UsedRange.Delete '見出しを付ける ThisWorkbook.Sheets(1).Range("B2") = "ファイル名" ThisWorkbook.Sheets(1).Range("C2") = "ファイル種別" ThisWorkbook.Sheets(1).Range("D2") = "最終更新日" ThisWorkbook.Sheets(1).Range("E2") = "説明" ThisWorkbook.Sheets(1).Range("B2:E2").Interior.Color = RGB(0, 0, 0) ThisWorkbook.Sheets(1).Range("B2:E2").Font.Color = RGB(255, 255, 255) ThisWorkbook.Sheets(1).Range("B2:Es2").HorizontalAlignment = xlCenter i = 3 For Each Fx In Fil 'ファイル名 sFile = FS.GetBaseName(sFile.Name) 'ファイル名の書き出し ThisWorkbook.Sheets(1).Cells(i, 2) = sFile 'ファイル種別 sFType = Fx.Type '最終更新日時の書き出し ThisWorkbook.Sheets(1).Cells(i, 3) = sFType '最終更新日 sLMod = Fx.DateLastModified ThisWorkbook.Sheets(1).Cells(i, 4) = sLMod i = i + 1 Next End Sub 'ファイル名 sFile = FS.GetBaseName(sFile.Name)の部分で ”オブジェクトが必要です”とエラーが出ます。

  • Excelマクロ 最後に画像を貼付けたい…

    Excelにファイル名、情報、画像を表示するマクロを作成したいと いろいろ探し、以下の参考マクロを探しました。 Sub MakeFileList() Target = InputBox("ディレクトリ名を入力", "ディレクトリの指定", "C:\Windows") Set FS = CreateObject("Scripting.FileSystemObject") Set Fol = FS.GetFolder(Target) Set Fil = Fol.Files ThisWorkbook.Sheets("Sheet1").UsedRange.Delete '見出しを付ける ThisWorkbook.Sheets(1).Range("B2") = "ファイル名" ThisWorkbook.Sheets(1).Range("C2") = "ファイル種別" ThisWorkbook.Sheets(1).Range("D2") = "最終更新日" ThisWorkbook.Sheets(1).Range("E2") = "説明" ThisWorkbook.Sheets(1).Range("B2:E2").Interior.Color = RGB(0, 0, 0) ThisWorkbook.Sheets(1).Range("B2:E2").Font.Color = RGB(255, 255, 255) ThisWorkbook.Sheets(1).Range("B2:Es2").HorizontalAlignment = xlCenter i = 3 For Each Fx In Fil 'ファイル名 sFile = Fx.Name 'ファイル名の書き出し ThisWorkbook.Sheets(1).Cells(i, 2) = sFile 'ファイル種別 sFType = Fx.Type '最終更新日時の書き出し ThisWorkbook.Sheets(1).Cells(i, 3) = sFType '最終更新日 sLMod = Fx.DateLastModified ThisWorkbook.Sheets(1).Cells(i, 4) = sLMod i = i + 1 Next End Sub   あと、最後の"F列"にファイル名の画像を貼付けたいのですが どのようにしたら良いのでしょうか? 教えてください。

  • 画像のプロパティー書き出し

    Excelに画像(例:001.bmp)のプロパティー情報の書き出し方を 教えてください。 "全般"タブの書き出し方はだいたい調べて解りました。 *下記コード参考 "概要"タブの書き出し方がわかりません。 下記のように入力するにはどうしたら良いのでしょうか? 教えてください。 *参考コード* ThisWorkbook.Sheets(1).Range("A1") = "パス" ThisWorkbook.Sheets(1).Range("B1") = "ファイル名" ThisWorkbook.Sheets(1).Range("C1") = "ファイル種別" ThisWorkbook.Sheets(1).Range("D1") = "最終更新日" ThisWorkbook.Sheets(1).Range("E1") = "フルパス" ~省略~ ThisWorkbook.Sheets(1).Cells(i, 1) = Target 'ファイル名 sFile = Fx.Name 'ファイル名の書き出し ThisWorkbook.Sheets(1).Cells(i, 2) = sFile 'ファイル種別 sFType = Fx.Type '最終更新日時の書き出し ThisWorkbook.Sheets(1).Cells(i, 3) = sFType '最終更新日 sLMod = Fx.DateLastModified ThisWorkbook.Sheets(1).Cells(i, 4) = sLMod 'フォルダフルパス SFull = Target & "\" & sFile ThisWorkbook.Sheets(1).Cells(i, 5) = SFull

  • Excel VBA 別ブックへの登録

    お世話になります。 今お仕事でExcelのVBAで同じフォルダ内の別ブックにデータを書き込みたくて いろいろやって見たのですが、上手くできません。 お力を頂ければと・・・・ <詳細> やりたいこと サーバー内に各個人の見積フォルダがあり、そのフォルダの中に見積作成と見積データの各ファイルが2つあります。 見積作成で作成したデータが登録ボタン(VBA)により見積データに登録されるようにしたい。 今までは同じブック内の別シートへデータを登録していました。 今回は同じフォルダ内の別ファイルへのデータ登録です。 ここまではできました・・・・ Sub 見積データ取得() Dim wSheet As ThisWorkbook Dim idx As String 'データ保存用シートを取得 Workbooks.Open Filename:=ThisWorkbook.Path & "見積データ.xls" Set wSheet = ThisWorkbook.Sheets(見積作成.xls) '空白行を取得 idx = CStr(wSheet.UsedRange.Row(wSheet.UsedRange.Rows.Count).Row + 1) '明細を取得 Dim wRange As Range Set wRange = ThisWorkbook.Sheets("見積作成").Range("B7:Q175") Dim i As Integer For i = 1 To wRange.Rows.Count If wRange.Cells(i, 6).Value <> "" Then '作成日 wSheet.Range("A" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("H2").Value '見積NO wSheet.Range("B" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("H5").Value '見積名 wSheet.Range("C" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("C1").Value '提出先NO wSheet.Range("D" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("B3").Value '提出先 wSheet.Range("E" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("C3").Value '提出先フリガナ wSheet.Range("F" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("Y5").Value '担当者 wSheet.Range("G" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("H1").Value '備考欄 wSheet.Range("S" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("C31").Value 'メーカー名 wSheet.Range("H" & idx).Value = wRange.Cells(i, 10).Value '商品NO wSheet.Range("I" & idx).Value = wRange.Cells(i, 1).Value '商品名 wSheet.Range("J" & idx).Value = wRange.Cells(i, 2).Value '入数 wSheet.Range("K" & idx).Value = wRange.Cells(i, 9).Value '数量 wSheet.Range("L" & idx).Value = wRange.Cells(i, 3).Value 'A価 wSheet.Range("M" & idx).Value = wRange.Cells(i, 5).Value '金額 wSheet.Range("N" & idx).Value = wRange.Cells(i, 6).Value 'C価 wSheet.Range("O" & idx).Value = wRange.Cells(i, 14).Value 'D価 wSheet.Range("P" & idx).Value = wRange.Cells(i, 16).Value '数量 'wSheet.Range("K" & idx).Value idx = CStr(CInt(idx) + 1) End If Next でも上手くいきません・・・ よろしくお願いいたしますm(_ _)m

  • excel  vba  シートの取り扱い

    Sub   aaa() Worksheets.Add ActiveSheet.Name = "Namefile" ((質問)ここへ適当なコードを追加することによって 以下のThisWorkbook.Sheets(1)というのを、上で追加した Namefileシートを処理することとしたい。 つまり  Namefileシート=ThisWorkbook.Sheets(1) どうすればいいか。よろしくお願いします。) ThisWorkbook.Sheets(1).UsedRange ThisWorkbook.Sheets(1).UsedRange.Delete ThisWorkbook.Sheets(1).Range("B2") = "ファイル名" ThisWorkbook.Sheets(1).Range("C2") = "最終更新日" End Sub

  • Next,End Withのエラー

    Sub 入力() If Sheets("入力").Range("D3").Value = "" Then MsgBox "客先名を入力して下さい" Else Dim K最終行 As Long Dim T最終行 As Long Dim i As Integer With Sheets("入力") For i = 3 To 12 If .Cells(i, "H").Value <> "" Then U最終行 = Sheets("注文書").Range("G65536").End(xlUp).Row + 1 If U最終行 = 461 Then MsgBox "注文書がいっぱいです" Exit Sub Else End If E最終行 = Sheets("営業確認").Range("G65536").End(xlUp).Row + 1 Sheets("営業確認").Range("k" & E最終行).Value = .Cells(i, "b").Value Sheets("営業確認").Range("b" & E最終行).Value = .Cells(i, "c").Value Sheets("営業確認").Range("c" & E最終行).Value = .Cells(i, "d").Value Sheets("営業確認").Range("d" & E最終行).Value = .Cells(i, "e").Value Sheets("営業確認").Range("g" & E最終行).Value = .Cells(i, "h").Value Sheets("営業確認").Range("f" & E最終行).Value = .Cells(i, "i").Value Sheets("営業確認").Range("i" & E最終行).Value = .Cells(i, "m").Value Sheets("営業確認").Range("h" & E最終行).Value = .Cells(i, "p").Value Else End If Select Case .Cells(i, "o").Value Case "北" K最終行 = Sheets("北").Range("h65536").End(xlUp).Row + 1 Sheets("北").Range("B" & K最終行).Value = .Cells(3, "C").Value Sheets("北").Range("c" & K最終行).Value = .Cells(3, "b").Value Case "中" T最終行 = Sheets("中").Range("H65536").End(xlUp).Row + 1 Sheets("中").Range("b" & T最終行).Value = .Cells(3, "c").Value Sheets("中").Range("c" & T最終行).Value = .Cells(3, "b").Value End Select Exit Sub Dim Dummy As Worksheet Dim SheetName As String Dim OTA As Long Dim GEN As Long Dim SheetName2 As String With Sheets("入力") '3行目~22行目まで For j = 3 To 22 SheetName = Sheets("入力").Range("D3").Value On Error Resume Next Set Dummy = Sheets(SheetName) SheetName2 = .Cells(i, 14).Value 'もしシートがあれば・・・ If Err.Number = 0 Then 'SheetName2は入力シートのN行 SheetName2 = .Cells(i, 14).Value OTA = Sheets(SheetName2).Range("B65536").End(xlUp).Row + 1 Sheets(SheetName2).Range("A7").Value = .Cells(3, "D").Value Sheets(SheetName2).Range("C3").Value = .Cells(3, "C").Value Sheets(SheetName2).Range("B" & OTA).Value = .Cells(i, "H").Value Sheets(SheetName2).Range("I" & OTA).Value = .Cells(i, "I").Value Sheets(SheetName2).Range("F" & OTA).Value = .Cells(i, "K").Value Sheets(SheetName2).Range("H" & OTA).Value = .Cells(i, "L").Value Sheets(SheetName2).Range("J" & OTA).Value = .Cells(i, "M").Value 'シートが無ければ・・・ Else GEN = Sheets("原紙").Range("B65536").End(xlUp).Row + 1 Sheets("原紙").Range("A7").Value = .Cells(3, "D").Value Sheets("原紙").Range("C3").Value = .Cells(3, "C").Value Sheets("原紙").Range("B" & GEN).Value = .Cells(i, "H").Value Sheets("原紙").Range("I" & GEN).Value = .Cells(i, "I").Value Sheets("原紙").Range("F" & GEN).Value = .Cells(i, "K").Value Sheets("原紙").Range("H" & GEN).Value = .Cells(i, "L").Value Sheets("原紙").Range("J" & GEN).Value = .Cells(i, "M").Value '原紙をコピーする Sheets("原紙").Copy BEFORE:=Sheets(1) 'シートの名前を市場コードにする Sheets(1).Name = SheetName Next End With Exit Sub On Error GoTo 0 Sheets("原紙").Select Range("C3:E3,A7,B16:B35,F16:F35,H16:J35").Select Range("H35").Activate Selection.ClearContents Sheets("入力").Select Sheets("入力").Range("D3,G3:J12,L3:M12").Value = "" Sheets("入力").Range("D3").Select Range("B3").Formula = "=IF(D3="""","""",VLOOKUP(D3,'\\Seika-sv01\支店共有\マーケティング用\[担当者リスト.xls]リスト形式'!$B:$D,3,FALSE))" MsgBox "入力が完了しました" End If End Sub 上記のようにマクロを組みましたがエラーが出てしまいます。

  • ExcelのCopy&Pastsについて

    セルを1個づつ上にずらせ1番下に新しいデータを書き込むようにしたくて次のようなプロシージャーで行っていますが 'PROG1: Sheets("sheet2").Select Range("V10:Z98").Select Selection.Copy Range("V9").Select ActiveSheet.Paste Application.CutCopyMode = False PROG1:4回繰り返します。 sheet1で作業をしていて上のように実行しますと画面が4回動いてしまします。 'PROG2: If Sheets("sheet2").Range("A23") = "MC1" Then Set objFrom = ThisWorkbook.Worksheets("あきない02") Set objTo = ThisWorkbook.Worksheets("あきない02") For i = 10 To 98 For j = 22 To 26 'objFrom.Cells(i, j).Copy Destination:=objTo.Cells(i - 1, j) objTo.Cells(i - 1, j).Value = objFrom.Cells(i, j).Value Next j Next i End If PROG2を4回繰り返します。すると画面は動かなくていいのですが終わるまでに3分ほどかかります。 画面を動かさずにもっと早くできる方法はないでしょうか?

  • マクロでのワイルドカードの使い方について

    マクロ初心者です! 下記の動きを実現したいです。 (1)ファイル「*あいう*」(※)の「シート#1」のF5→AE24までの値をコピー →上記の値をすべて加算し、「貼り付け先ファイル」のF5→AE24に貼り付け ※「某フォルダ」に存在する、ファイル名に「あいう」を含むすべてのファイル(ファイル数は可変)が対象 (2)上記を同様の動きを、範囲のすべてのセルでなく、 (F25:F42)、(H25:H42)、、~(AD25:AD42)と1列ごとに対して行う 方々で知識のある方からご助力いただき、 下記の「それっぽい」記述までは辿り着いたのですが、上手く動かず。。 また、(1)と(2)は1つにできるのでは?とも推測してますが、どのように書けば間違いないのかわからない状況です…! 知識のある方から、間違いや改善点などご教示いただけたらとてもうれしいです。 Sub (1)() Dim folder As String Dim dws As Worksheet Dim sfile1 As String Dim swb1 As Workbook Dim adr As String folder = "C:\Users\某フォルダ\" Set dws = ThisWorkbook.Worksheets("貼り付け先シート") sfile1 = Dir(folder & "*あいう*.xlsm") If sfile1 = "" Then Exit Sub Set swb1 = Workbooks.Open(folder & sfile1) adr = Range(Cells(5, 6), Cells(24, 31)).Address(0, 0, 1) swb1.Sheets("シート#1").Range(adr).Copy dws.Range(adr).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd swb1.Close False End Sub Sub (2)() ((1)と同じ宣言) Dim c As Integer folder = "C:\Users\某フォルダ\" Set dws = ThisWorkbook.Worksheets("貼り付け先シート") sfile1 = Dir(folder & "*あいう*.xlsm") If sfile1 = "" Then Exit Sub Set swb1 = Workbooks.Open(folder & sfile1) For c = 6 To 30 Step 2 adr = Range(Cells(25, c), Cells(42, c)).Address(0, 0, 1) swb1.Sheets("シート#1").Range(adr).Copy dws.Range(adr).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd Next swb1.Close False End Sub

  • エクセルのマクロでファイル名変更

    Dim フォルダ パス = ActiveWorkbook.Path 本体 = ActiveWorkbook.Name 変更1 = Sheets(1).Range("B2") フォルダ = パス & "\" & 変更1 ' & "\" 拡張子 = Sheets(1).Range("B3") 語句1 = Sheets(1).Range("B5") 語句2 = Sheets(1).Range("C5") aa = 1 '7777777777 指定フォルダの書き出し 7777777777 Dim myFileName As String Sheets(1).Select Range("B7:B1000").Clear Range("D7:E1000").Clear 'Rows("2:10000").ClearContents '隠しファイルとシステムファイルも表示 myFileName = Dir(フォルダ & "\" & "*." & 拡張子, vbHidden + vbSystem) Sheets(1).Select While myFileName <> vbNullString Cells(Rows.Count, 2).End(xlUp).Offset(1).Value _ = myFileName myFileName = Dir() Wend 下端 = Range("B" & Rows.Count).End(xlUp).Row rrname = 1 For a = 7 To 下端 If rrname < 10 Then Cells(a, 4) = "第00" & rrname & "話" & Cells(a, 3) & "." & 拡張子 ElseIf rrname >= 10 Then Cells(a, 4) = "第0" & rrname & "話" & Cells(a, 3) & "." & 拡張子 ElseIf rrname >= 100 Then Cells(a, 4) = "第" & rrname & "話" & Cells(a, 3) & "." & 拡張子 End If rrname = rrname + 1 Next a For b = 7 To 下端 旧ファイル名 = Cells(b, 2).Value 新ファイル名 = Cells(b, 4).Value Name フォルダ & "\" & 旧ファイル名 As フォルダ & "\" & 新ファイル名 Next b でファイル名変更マクロを作成したのですが、『ファイル名または番号が不正です』とエラーが返ってきますが、何が悪いのでしょうか?

専門家に質問してみよう