複数のテキストファイルを一括でエクセルに取り込みたい。

VBA初心者です。宜しくお願いします。
複数のテキストファイルを一括でエクセルの同一Bookにシート毎に取り込みたいと考えております。ネットを色々調べてみて取り込みまでは出来たのですが、テキスト内容は空白によって区切られているので、セルごとに区切られません。エクセルにて1ファイルごとは取り込めるのですが、一括の場合は一つのセルにテキストがまとまってしまします。行は分かれてますが列が分かれません。色々と試しましたが、知識が無いためにこれ以上進みません。どうかお力を貸して下さい。win Excel2016です。

下記のソース？で取り込む事が出来ました。
Sub ReadTextFiles()
　　Const DirName = "C:\Users\"
　　'上記で指定されたフォルダに存在するファイルで、
　　'拡張子がtxtのものをすべて１シートとして読み込む
　　Dim fs As Object
Dim dir 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

また下記がエクセルマクロにて保存した内容です。
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Users\.txt", Destination:=Range( _
"$A$1"))

.CommandType = 0
.Name = "1001"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 932
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub

No.3 ベストアンサー 回答者： ki-aaa 回答日時： 2017/01/07 00:45

このように変更したらどうなりますか

myArray = Split(stream.ReadLine, Space(1))
↓
myArray = Split(stream.ReadLine, vbTab)

この回答へのお礼

ki-aaaさん有難う御座います。求めている結果になりました。

お礼日時：2017/01/07 13:34

No.2 回答者： tatsu99 回答日時： 2017/01/06 23:05

いかのようにしてください。

-------------------------------------
Sub ReadTextFiles()
Const DirName = "C:\Users\"
'上記で指定されたフォルダに存在するファイルで、
'拡張子がtxtのものをすべて１シートとして読み込む
Dim fs As Object
Dim dir As Object
Dim RE As Object
Dim fc As Object
Dim f1 As Object
Dim stream As Object
Dim line As String
Dim items As Variant
Dim i As Long
Dim row As Long
Set RE = CreateObject("VBScript.RegExp")
RE.Pattern = "[ ]+"
RE.Global = True
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
row = stream.line
'連続する空白を１つにまとめる
line = stream.ReadLine
line = RE.Replace(line, " ")
items = Split(line, " ")
For i = 0 To UBound(items)
Cells(row, 1 + i).Value = items(i)
Next
Loop
stream.Close
End If
Next
End Sub
---------------------------

この回答へのお礼

tatsu99さん有難う御座います。動作はしますが結果としては最初の状態と同じでした。

お礼日時：2017/01/07 13:35

No.1 回答者： ki-aaa 回答日時： 2017/01/06 00:21

これでどうかな

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

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
myArray = Split(stream.ReadLine, Space(1))
If UBound(myArray) >= 0 Then
Cells(stream.Line, 1).Resize(1, UBound(myArray) + 1).Value = myArray
End If
Loop

stream.Close
End If
Next
End Sub

この回答へのお礼

ki-aaaさん有難う御座います。私の説明がいけないんだと思いますが、取り込みはしましたけど私が記述した結果と同じでした。たぶんテキストデータの説明が悪いんだと思います。

動作結果このような形です。
文字列が分割されず、一つ目のセルに記述された状態です。

1111111あいうえお22222かきくけこ333333さしすせそ
2222222たちつてと55555さしすせそ7777779999999999

Cells(stream.Line, 1).Resize(1, UBound(myArray) + 6).Value = myArray　とした場合に、
一つのセル毎に分割されない文字列がインポートされました。

参考になるか解りませんが、メモ帳に記述されているテキスト例はこのような感じです。

1111111　　あいうえお　22222　かきくけこ　333333　さしすせそ
2222222　　たちつてと　55555　さしすせそ　777777　9999999999
　　
1ファイルをエクセルにてインポートする場合は、区切り文字で区切られています。
データプレビューにてみると、一つ目のセルと二つ目のセルの区切りを2列目の文字頭で
区切りがあり、以降の列も文字頭で区切られております。　　

1111111　　｜あいうえお　｜22222　｜かきくけこ　｜333333　｜さしすせそ
2222222　　｜たちつてと　｜55555　｜さしすせそ　｜777777　｜9999999999

上手く伝えられなくて申し訳ありません。

お礼日時：2017/01/06 20:41