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

Question

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

ki-aaa · Accepted Answer

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

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

tatsu99 · Answer

いかのようにしてください。
-------------------------------------
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
---------------------------

ki-aaa · Answer

これでどうかな

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

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

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

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

これでどうかな

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング