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

質問

お世話になります。
ファイルの一覧を作成するマクロを作っていますが、
拡張子を表示させないようにしたいのですが
”オブジェクトが必要です”と
エラー出てなかなかうまくいきません。
どなたか助けてください。

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)の部分で
”オブジェクトが必要です”とエラーが出ます。

回答No.3

eden3616 · ベストアンサー

No2の捕捉です。
ThisWorkbook.Sheets(1).Range("B2:Es2").HorizontalAlignment = xlCenter
となっておりますが、「B2:E2」の間違いですよね？

最下のVBAコードは変数の型宣言部を加え、コードを整理しましたのでご参考ください。
以下の3点を変更しております。

(1)無駄な変数への格納を廃止して直接セルへ書き出し
　　sFile 、sFType 、sLMod の変数を使っていませんので除外しております。
(2)シート名の指定方法を統一
　　ご提示のコードで前半はSheets("Sheet1")、後半はSheets(1)とされておりますが
　　前者はシート名がSheet1、後者は左から1番目のシートとなり、意味が異なります。
　　場合においては誤作動の原因となりますので、前者の方法で統一しております。
　　（※Sheetsですとグラフシートも対象となりますので、Worksheetsを使用しています）
(3)フォルダの参照ダイアログを実装
　　フォルダパス入力による指定のほか、参照ボタンが利用できるようにShell.Applicationを使用しています。

■VBAコード
Sub MakeFileList()
　　Dim FS As Object, Shell As Object
　　Dim fol As Object, fil As Variant, target As String
　　Dim i As Long, fx As Variant

　　Set Shell = CreateObject("Shell.Application")
　　target = Shell.BrowseForFolder(&O0, "ディレクトリの指定", &H1 + &H10, "C:\Windows\").Items.Item.Path
　　Set FS = CreateObject("Scripting.FileSystemObject")
　　Set fol = FS.GetFolder(target)
　　Set fil = fol.Files

　　'作画停止
　　Application.ScreenUpdating = False
　　'見出しを付ける
　　With ThisWorkbook.Worksheets("Sheet1")
　　　　.UsedRange.Delete
　　　　With .Evaluate("B2:E2")
　　　　　　.Value = [{"ファイル名","ファイル種類","最終更新日","説明"}]
　　　　　　.Interior.Color = RGB(0, 0, 0)
　　　　　　.Font.Color = RGB(255, 255, 255)
　　　　　　.HorizontalAlignment = xlCenter
　　　　End With
　　　　i = 3
　　　　For Each fx In fil
　　　　　　'ファイル名の書き出し
　　　　　　.Cells(i, 2) = FS.GetBaseName(fx.Name)
　　　　　　'ファイル種別の書き出し
　　　　　　.Cells(i, 3) = fx.Type
　　　　　　'最終更新日の書き出し
　　　　　　.Cells(i, 4) = fx.DateLastModified
　　　　　　i = i + 1
　　　　Next fx
　　End With
　　'作画開始
　　Application.ScreenUpdating = True
End Sub

お礼

ありがとうございます。
拡張子も取れて思い通りの結果ができました。
また機会がありましたらよろしくお願いします。

回答No.2

eden3616

型宣言をした方がよいかと思います。
とりあえず動作するようにするには以下の点を変更してみてください。

sFile = FS.GetBaseName(sFile.Name)
　　　　　　　↓
sFile = FS.GetBaseName(Fx.Name)

回答No.1

dogs_cats

修正案の一例です。
下記コードはサイトにあったVBA2003仕様のコードの丸写しのようですね。
エラー部分の変数sFileは無くても動きますので、不使用としました。
Fx.name,Fx.Typeでデータ取得は可能でした。私も独学なので、エラー理由までは詳しく書けませんが。

変数　fol,filも無くても可能だと感じました。
For Each fx In filをFor Each fx In Fs.GetFolder(Target).filesにする事で変数は２つ不要になります。

質問者さんの問題ではなく、サイトにこのコードを記載した人の問題なのですが、変数を宣言しなくても事項する事は可能なのですが、他人が見てわかるように、コードの冒頭に変数の型式も一緒に宣言するのがプログラムを作成される方々のルールになっていますので変数の宣言の無いコードをサイトから転用する事は控えた方が良いと思います。
（私は独学のプrグラムを作成するという程の者ではありませんが）

気になった点
１）データ入力シートはSheets(1)に統一しましたが、これはシート名sheet1を示している訳ではありません。一番左にあるシートからインデック番号が割り振られますのでsheet2が一番左にあればSheets(1)はsheet2にデータを記入しにいきます。
出来ればsheet1といった、シート名を指定した方が間違う確率は減るかと思います。
修正されるならシート名も変数に格納する事も可能です。
dim ws as worksheet

set ws= thisworkbook.sheets("sheet1")

ThisWorkbook.Sheets(1).UsedRange.Deleteは下記の様に短いコードで可能となります。
ws.UsedRange.Delete

２）inputboxのデフォルトのフォルダがC:\windowsになっていますが、本当にこれ良いのでしょうか？

3)シートにファイルデータを記入しますが、フォルダパスを記入していませんが、それで良いのでしょうか？どこのフォルダのファイル一覧であるか記入が必要ではないかと感じました。

Sub MakeFileList()

Dim i As Long
Dim Target As String
Dim Fs, fol, fil As Object
Dim fx As Variant
Dim sLMod As Date

Target = InputBox("ディレクトリ名を入力", "ディレクトリの指定", "C:\Windows")

Set Fs = CreateObject("Scripting.FileSystemObject")
Set fol = Fs.GetFolder(Target)
Set fil = fol.Files
ThisWorkbook.Sheets(1).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) = fx.Name
'ファイル種別
sFType = fx.Type
'最終更新日時の書き出し
ThisWorkbook.Sheets(1).Cells(i, 3) = fx.Type
'最終更新日
sLMod = fx.DateLastModified

ThisWorkbook.Sheets(1).Cells(i, 4) = sLMod
i = i + 1
Next

Set Fs = Nothing
Set fol = Nothing
Set fil = Nothing

End Sub

お礼

ありがとうございます。
また機会がありましたらよろしくお願いします。

補足

ありがとうございます。
一覧の作成はできますが
ファイル名にある拡張子を表示しない方法はありますでしょうか。