フォルダ名をだすには

質問

以下のコードでファイル名一覧がだせる。しかしフォルダ名がでない
フォルダ名をだすには、どうすればいいか。
　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

回答No.6

imogasi · ベストアンサー

下記で動きましたが。
Target = CurDir
Set bk = appexcel.Workbooks.Open(CurDir & "\" & "Book7.xls")
の部分はテストしやすいように我流ですから、適当に変えてください。
エクセルを立ち上げていない
ForEachで繰り回す必要がある
など質のコードには不足しているのでは。
ーーー
ub macro1()
Target = CurDir
MsgBox CurDir
Set FS = CreateObject("Scripting.FileSystemObject")
Set Fol = FS.GetFolder(Target)

Set Fil = Fol.Subfolders
i = 1
Set appexcel = CreateObject("Excel.Application")
Set bk = appexcel.Workbooks.Open(CurDir & "\" & "Book7.xls")
For Each fx In Fil
'MsgBox fx.Name
'サブフォルダ名
sFile = fx.Name
'サブフォルダ名の書き出し

bk.Sheets(1).Cells(i, "B") = sFile
'ファイル種別
sFType = fx.Type
'最終更新日時の書き出し
bk.Sheets(1).Cells(i, "C") = sFType
'最終更新日
sLMod = fx.DateLastModified
bk.Sheets(1).Cells(i, "D") = sLMod
i = i + 1
Next
bk.Close
Set bk = Nothing
Set appexcel = Nothing
End Sub

お礼

意図したものが出力できました。
非常に感謝いたします。

回答No.5

hallo-2007

お詫びに、コードの最後に（End Sub と Nextの間に）

Set Fil = Fol.Subfolders
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

を入れて同じ内容をフォルダーに対して実行してみて下さい。
今、試してみました。

お礼

動作を確認できました。
どうもありがとうございます。

回答No.4

hallo-2007

No2,No3です。
質問を勘違いしていました。
No1の方のアドバイス参考にしてください。
指定したディレクトリに中にあるサブフォルダの名前を取得したいのですね。
すみません。スルーしてください。

回答No.3

hallo-2007

あれれ？
コードをそのままコピィして
sFile = Fx.Name
'ファイル名の書き出し
ThisWorkbook.Sheets(1).Cells(i, 2) = sFile
の場合　B列に　Book1.xls　と出たのが

sFile = Fx.Path
'ファイル名の書き出し
ThisWorkbook.Sheets(1).Cells(i, 2) = sFile
にしたら
C:\Windows\mydoc\Book1.xls
^^^^^^^^^^^^^^^^^
と出たのですが、この事ではなかったのでしょうか。
ちなみに、
ThisWorkbook.Sheets(1).Cells(i, 6) = Fx.Path
一行入れてもF列に出ましたが。
>このような情報はどうやったら得られますか
まぐれです。

回答No.2

hallo-2007

試しにと思って
sFile = Fx.Name　を
sFile = Fx.Path　に変えたらパスとファイル名が出ますね。
MID関数使ってパスだけにするとかは如何でしょうか？
でもこの場合　フォルダ名は　Targetでは
MsgBox Target で表示されるのはご希望のこととは違いますか。

お礼

回答どうもありがとうございます。
しかし
sFile = Fx.Name　を
sFile = Fx.Path　に変えたらパスとファイル名が出ますね。

とありますが実験してもフォルダ名はでてきませんが、本当にでたのでしょうか。

For Each Fx In Fil
'
sFile = Fx.Path　
'名の書き出し
ThisWorkbook.Sheets(1).Cells(i, 2) = sFile
'ファイル種別
sFType = Fx.Type

ということですよね。

補足

sFile = Fx.Name　を
sFile = Fx.Path　

このような情報はどうやったら得られますか

回答No.1

mt2008

コード中の↓で、対象フォルダ内のファイル情報をFilにセットしていますよね。
Set Fil = Fol.Files

サブフォルダの情報は、このコードで言えば　Fol.Subfolders ですので、ファイルと同様にセットしてファイル情報を書き出しているのと同様にループを回して書き出します。

お礼

適切なコメントありがとうございました。
おかげで解決しました。