取り込むファイルのファイル名をセルに返したい

質問させてください。

以下のコードを使用していますが改良したいのです。

①現在はダイヤログが出てファイルを選択しています。
これを同じくダイヤログが出て、指定したフォルダー（C:\Users\○○○\Desktop\テストフォルダ\）
からファイル選択したい。


②取り込むテキストファイルのファイル名を取得してsheet1のセルB1に返したい。
（ファイル名が「000001.txt」だった場合、セルに「000001」と返したい）

　②について、Dir関数を使うのでしょうか？
　いろいろ調べてやってみたのですが、もうわからなくなりました。
　申し訳ありませんが教えていただけませんでしょうか？

　宜しくお願い致します。
　



Sub txt1()

Dim txtName As String
txtName = Application.GetOpenFilename("テキストファイル,*.txt")
If txtName <> "False" Then
Open txtName For Input As #1
End If
Dim r As Long
r = 1
Do Until EOF(1)
Dim buf As String
Line Input #1, buf
Dim aryLine As Variant
aryLine = Split(buf, ",")
Dim i As Long
For i = LBound(aryLine) To UBound(aryLine)
Cells(r, i + 1) = aryLine(i)
Next
r = r + 1
Loop
Close #1



End Sub

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2020/10/03 15:00

ChDir CreateObject("WScript.Shell").SpecialFolders("Desktop")

を
ChDir "C:\Users\○○○\Desktop\テストフォルダ" など
String型でパスを指定します。

この回答へのお礼

ありがとうございました❗
とても素晴らしいものになりました。
機会がありましたらまた質問させて下さい。

お礼日時：2020/10/03 18:31

No.1 回答者： Qchan1962 回答日時： 2020/10/03 10:01

こんにちは、

＞以下のコードを使用していますが改良したいのです。

①
カレントディレクトリを変更してSpecialFolders("Desktop")を使います。
Dim OldPath As String, txtName As String
OldPath = CurDir
ChDir CreateObject("WScript.Shell").SpecialFolders("Desktop")
txtName = Application.GetOpenFilename("*,*.")


②
Application.GetOpenFilenameからなので、文字列抽出するだけです。

Dim Pos As Integer
Pos = InStrRev(txtName, "\") + 1
Debug.Print Left(Mid(txtName, Pos), InStr(Mid(txtName, Pos), ".") - 1)
ChDir OldPath　'一応カレントディレクトリを元に戻します

まとめ

Dim OldPath As String, txtName As String
Dim Pos As Integer
OldPath = CurDir
ChDir CreateObject("WScript.Shell").SpecialFolders("Desktop")
txtName = Application.GetOpenFilename("テキストファイル,*.txt")
If txtName <> "False" Then
Pos = InStrRev(txtName, "\") + 1
Range("B1").Value = Left(Mid(txtName, Pos), InStr(Mid(txtName, Pos), ".") - 1)
ChDir OldPath　'カレントディレクトリを戻します。
Open txtName For Input As #1
End If

この回答へのお礼

なるほど！大変勉強になります。

ちなみにDesktopではなく、フォルダのパスで指定したい場合はどのようにしたら良いのでしょうか？

お礼日時：2020/10/03 14:31