エクセルの各シートに複数のtxtファイルを取り込む

質問

はじめまして．
Excel2013を用いたデータ整理でわからない部分があるため，
質問させていただきました．

同じフォルダに入った，複数(40個程度)のテキストファイルを，
エクセルの複数のシートにそれぞれ取り込みたいと考えています．
具体的には，同じフォルダに入っている，
A001.txt, A002.txt, A003.txt, ....
というテキストファイル群を，
Data_A.xlsxのSheet1にA001.txt
　　　　　　Sheet2にA002.txt
　　　　　　Sheet3にA003.txt
といったように取り込みたいです．

テキストファイルは，
X_座標　Y_座標　X_速度　Y_速度
の四列で構成されており，タブでそれぞれ区切られています．
行数は20,000程度です．

以前，同様の質問をされた方の回答にありました以下のマクロを実行してみたのですが，
・タブで区切られず，一つのセルに四列分の文字が入力される．
・0の情報が消えてしまう．
という二つの問題が発生しました．

Sub ReadTextFiles()
　　Const DirName = "C:\TEMP"
　　'上記で指定されたフォルダに存在するファイルで、
　　'拡張子がtxtのものをすべて１シートとして読み込む

　　Dim fs, dir, fc, f1, stream As Object
　　Set fs = CreateObject("Scripting.FileSystemObject")
　　Set dir = fs.GetFolder(DirName)
　　Set fc = dir.Files
　　For Each f1 In fc
　　　　If LCase(fs.GetExtensionName(f1.Name)) = "txt" Then
　　　　　　Worksheets.Add after:=Worksheets(Worksheets.Count)
　　　　　　Sheets(Worksheets.Count).Name = f1.Name
　　　　　　Set stream = f1.OpenAsTextStream
　　　　　　Do While stream.AtEndOfStream <> True
　　　　　　　　Cells(stream.Line, 1) = stream.ReadLine
　　　　　　Loop
　　　　　　stream.Close
　　　　End If
　　Next
End Sub

これらを解決した上で，ファイルを取り込む方法を教えていただきたいです．
お手数ですが，よろしくお願い致します．

回答No.3

mt2015 · ベストアンサー

ANo.2です。
テキストは3つではなくもっとたくさんあるのですね。
失礼しました。
新しいシートを追加して、シート名をテキストファイル名に変更したうえでデータを貼り付けるようにしました。
＃テキストファイル名と同名のシートが存在するとエラーになります。

Sub Sample()
　　Dim sPath As String
　　Dim sFile As String
　　Dim sText As String
　　sPath = "C:\TEMP\"
　　sFile = Dir(sPath & "*.txt")
　　Do While sFile <> ""
　　　　ActiveWorkbook.Worksheets.Add After:=Sheets(Sheets.Count)
　　　　ActiveSheet.Name = Replace(sFile, ".txt", "")
　　　　sText = "TEXT;" & sPath & sFile
　　　　With ActiveSheet.QueryTables.Add(Connection:=sText, Destination:=Range("$A$1"))
　　　　　　.TextFilePlatform = 932
　　　　　　.TextFileTabDelimiter = True
　　　　　　.Refresh
　　　　　　.Delete
　　　　End With
　　　　sFile = Dir()
　　Loop
End Sub

補足

ご回答ありがとうございます．
早速試してみたのですが，マクロを実行しても反応がありませんでした．
恐らく，こちらでパスの名前等を任意に変更するのができていないのが問題と思われます．
くだらない質問ですが，このプログラムでこちらが任意に変更すべき部分はどこになるでしょうか？
ご回答よろしくお願い致します．

回答No.4

mt2015

> くだらない質問ですが，このプログラムでこちらが任意に変更すべき部分はどこになるでしょうか？

sPath = "C:\TEMP\" ←この部分をtxtファイルが入っているパスに書き換えてください（最後の\も忘れずに）
#サイト上では逆スラッシュになっていますが、PC上では半角の￥です（日本語OSの場合）。

お礼

ご指摘の箇所を修正したところ，正常にマクロがはたらき欲しかった結果が得られました．
丁寧なご回答をして頂き，誠にありがとうございました．

回答No.2

mt2015

こんな感じでどうでしょう。
QueryTables.Add を使いました。

Sub Test()
　　Dim ws As Worksheet
　　Dim qt As QueryTable
　　Dim sText As String

　　For i = 1 To 3
　　　　sText = "TEXT;C:\TEMP\A" & Format(i, "000") & ".txt"
　　　　Set ws = Worksheets("Sheet" & i)
　　　　ws.Cells.Clear
　　　　Set qt = ws.QueryTables.Add(Connection:=sText, Destination:=ws.Range("A1"))
　　　　With qt
　　　　　　.TextFilePlatform = 932
　　　　　　.TextFileTabDelimiter = True
　　　　　　.Refresh
　　　　　　.Delete
　　　　End With
　　Next i
End Sub

回答No.1

emsuja

少々泥臭い書き方ですが、こんな書き方では？

Option Explicit
Dim sn As String, fn As String

Sub test()
Dim pn As String
pn = ThisWorkbook.Path

fn = pn & "\aaa001.txt"
sn = "sheet1"
Call test2

fn = pn & "\aaa002.txt"
sn = "sheet2"
Call test2

pn = ThisWorkbook.Path
fn = pn & "\aaa003.txt"
sn = "sheet3"
Call test2

fn = pn & "\aaa004.txt"
sn = "sheet4"
Call test2

End Sub

Sub test2()
Dim f As Integer, w As String, d() As String, r As Long, c As Integer
With Worksheets(sn)
f = FreeFile
Open fn For Input As f
Do Until EOF(f)
Line Input #(f), w
d() = Split(w, vbTab)
r = r + 1
For c = 0 To UBound(d)
.Cells(r, c + 1).Value = d(c)
Next
Loop
Close f
End With

End Sub

お礼

迅速なご回答，誠にありがとうございました．