Excel VBA ファイル名を同セルへ

質問

500件ほどのアンケートの集計作業をしています。
フォルダ内のファイル名(アンケート(１)、アンケート(２)…)をそれぞれsheet1のセルX1へ入力させたいと思っています。(アンケートはsheet1、sheet2、sheet3の3シートで構成されています。)どなたかご教授いただけないでしょうか。

回答No.1

nishi6 · ベストアンサー

対象のフォルダー(elmWB_Path)はセットしてください。
事前に、テストをしてください。

当方、Win10、Excel2010です。

Sub setBookName()
　Dim elmWB_Path As String　　'// 対象のフォルダー
　Dim elmWB_Name As String　　'// 対象のブック名(*.xlsx)
　Dim elmWB As Workbook　　　 '// 開いたブック名
　Dim getWB_Name As String　　'// 対象のブック名
　　elmWB_Path = "N:\****\****"
　　elmWB_Name = "*.xlsx"

　Application.ScreenUpdating = False
　getWB_Name = Dir(elmWB_Path & "\" & elmWB_Name)
　While getWB_Name <> ""
　　Set elmWB = Workbooks.Open(elmWB_Path & "\" & getWB_Name)
　　With elmWB
　　　.Worksheets("Sheet1").Range("X1") = Left(.Name, Len(.Name) - 5)
　　　.Close SaveChanges:=True
　　End With

　　getWB_Name = Dir()
　Wend
　Application.ScreenUpdating = True
End Sub

回答No.2

imogasi

このタイプの質問はありふれている。ＷＥＢ照会すればすぐわかる。
検索語「vbscript フォルダ ファイル 取得」など。
ＶＢＡをやるというのに、ＷＥＢ照会を使ってないのなど不思議。
既出回答は出ているが、VBScriptでやる方がわかりやすかろう。それで挙げてみる。
https://bayashita.com/p/entry/show/33　を拝借したと言えるもの（そのままに近い）
下記のIf i > 10 Then Exit Forは最初９個に限ったもの。
この行を除けば、あるだけ出てくる。
x = "C:\Users\ＸＸＸ\Documents\"は、エクスプローラーで、そのフォルダのプロパティを出して、コピーすること。スラッシュは円マーク￥（半角）です。
ーー
「sheet1のセルX1へ入力させたい」は、表現がわかりにくい。Ｘ列が具体的にあるから。また、インプットというより、むしろアウトプットだろう？
数学の未知数のような、考えでＸを使ってはわかりにくい。
「列方向（第１行目）に順次」とでもいうべきか？
ーーーー
Option Explicit
Sub test01()
Dim objFileSys
Dim objFolder
Dim objFile
Dim x As String
Dim i As Long
'ファイルシステムを扱うオブジェクトを作成
Set objFileSys = CreateObject("Scripting.FileSystemObject")

'c:\temp フォルダのオブジェクトを取得
x = "C:\Users\ｘｘｘ惇\Documents\"
Set objFolder = objFileSys.GetFolder(x)
i = 1
'FolderオブジェクトのFilesプロパティからFileオブジェクトを取得
For Each objFile In objFolder.Files
'取得したファイルのファイル名を表示
'Cells(i, "A") = objFile.Name '行方向に出す場合
Cells(1, i) = objFile.Name
i = i + 1
If i > 10 Then Exit For
Next
MsgBox "終り"
Set objFolder = Nothing
Set objFileSys = Nothing
End Sub
一応一例でテスト済み。