複数ファイルをエクセルに取り込む方法

質問

複数のテキストファイルを各シート毎にエクセルマクロを用いて貼りつけたいです。
【テキストの内容】
AAA BBB CCC DDD・・・
EEE FFF GGG HHH・・・
III JJJ KKK LLL・・・
・
・
・
上記のようなようなデータが書かれた複数のテキストファイルを各シート毎に張り付けるマクロを探していたところ
下記のようなものを見つけました。
しかし、
マクロを動かした所、一つのセルに一行分が入ってしまいます。
例)セルA1に
AAA BBB CCC DDDが貼り付けられてしまう
セルA2に
EEE FFF GGG HHHが貼り付けられてしまう

可能であればスペース区切りでセルA、セルB、セルCに分けたいです。
例)セルA1に
AAAが貼り付けられる
セルB1に
BBBが貼り付けられる
セルC2に
CCCが貼り付けられる

スペース区切りで張り付けらる方法をご教示ください。

===========================
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.1

kkkkkm · ベストアンサー

以下で試してみてください。

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

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
mRow = stream.Line
tmp = Split(stream.ReadLine, " ")
For mCol = 1 To UBound(tmp) + 1
Cells(mRow, mCol).Value = tmp(mCol - 1)
Next
Loop
stream.Close
End If
Next
End Sub

お礼

回答ありがとうございます。

大変助かりました。

少しづつ自分でも勉強していきたいと思います。

補足

回答ありがとうございます。

回答頂いたマクロを動かした結果、スペース分セルがあいてしまいました。
細かくなって申し訳ないですが
スペースの数（１つ、２つ）関係なく貼り付けられるには、どこを修正すればよろしいでしょうか？

例）
【テキスト内容】
AAA BBB CCC A'A'A'
↓
【エクセル貼り付け結果イメージ】
A B C D
1AAA BBB CCC A'A'A'
2DDD EEE FFF D'D'D'
3GGG HHH III G'G'G'

説明が下手で申し訳ありません。

回答No.8

kkkkkm

No.4の補足です。

スペースの数によっては空白セルが必要、たとえば5個の時だけ1つセルを飛ばしたいなどの場合は

Do While stream.AtEndOfStream <> True
mRow = stream.Line
tmp = Split(Application.WorksheetFunction.Trim(stream.ReadLine), " ")
For mCol = 1 To UBound(tmp) + 1
Cells(mRow, mCol).Value = tmp(mCol - 1)
Next
Loop

のところを以下に変更すると可能です。

Do While stream.AtEndOfStream <> True
mRow = stream.Line
tmp = stream.ReadLine
tmp = Replace(tmp, " ", "@@@@@")
tmp = Application.WorksheetFunction.Trim(tmp)
tmp = Replace(tmp, "@@@@@", " ")
tmp = Split(tmp, " ")
For mCol = 1 To UBound(tmp) + 1
Cells(mRow, mCol).Value = tmp(mCol - 1)
Next
Loop

あと、最初、データの一行が同じ行だけでは無い可能性を考えて(C2記載があったので)以下にしていましたが、一行は同じ行だという事ですので

For mCol = 1 To UBound(tmp) + 1
Cells(mRow, mCol).Value = tmp(mCol - 1)
Next

のところを

Cells(mRow, 1).Resize(1, UBound(tmp) + 1).Value = tmp

にしておいてもいいかもしれません。

回答No.7

m3_maki

質問者さんのコードの最後に以下のコードを追加してください。
分割は エクセルまかせにします。

Columns("A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False

回答No.6

imogasi

もう過去のWEBにあったコードに、こだわった修正コードは教えてもらったようだ。
しかしこんなことを、していると進歩も改善も出来ないよ。
ーー
>下記のようなものを見つけました。
それはそれであり得るとして、その見つけたVBAコードの各行で
、何をしているか勉強してから、自分のニーズの中で使うべきだろう。
ーー
其れか、自分で処理を箇条書き文章にして、その１行の処理に当たるコードを
WEBで探すべきだ。「エクセル　VBA　XXX」で照会する。その「XXX]の分類分け
＝カテゴリ分け＝パターン分け、が出来ないと、VBAの勉強で、自立できないのだ。

本件では（A）テキストファイル（複数らしい）と（B)エクセルブック（1つらしい）は
開いておく必要がある。
（A）がフォルダーにある順で（B)にデータを持ってくるものとする。
(この点を質問に、書いてない＝断ってない、のは素人らしい至らぬ点だ。
（B)は最初に１回、（A)は順次開く。
（A)テキスト・ファイルはForEachで読み、除外するファイルはそのフォルダーに無いものとする。
処理が終われば、CLOSEするのは当たり前。
（１）第1テキストファイルを開く
　　　第1行を第Ⅰシートに貼りつける。その際スペース区切りとして、各列に
　　　張り付ける。テキストファイルの最終行まで繰り返す。
（２）第2シートを選択
　　　第2のテキストファイルを開き、（１）と同じ処理をする。
終ればブックのClose。
ーー
参考になるコードは
Sub test01()
dt = "aaa bbb ccc dd ee" '元テキストデータ　スペース区切りとして
d = Split(dt, " ") 'split関数の利用
i = 1 '第1行目　'張り付け先行を指定
Worksheets("Sheet1").Range("A" & i & ":" & "E" & i) = d 'シートへ、各列に張り付け
End Sub
ーー
（１）フォルダの中のファイルを捕まえる（２）テキストファイルのレコードRead処理はFSOを
使うべきと思う。VBAにもある。

回答No.5

NuboChan

AIさんに回答を求めた結果です。

Option Explicit

Sub SplitTextFile()
Dim filePath As String
Dim fileContent As String
Dim fileLines() As String
Dim cellValues() As String
Dim i As Long, j As Long

'Specify the path of the text file
filePath = "C:\Users\TAC_\Desktop\test.txt"

'Read the contents of the text file
Open filePath For Input As #1
fileContent = Input$(LOF(1), 1)
Close #1

'Split the text file into lines
fileLines = Split(fileContent, vbCrLf)

'Loop through each line and split it into cell values
For i = LBound(fileLines) To UBound(fileLines)
cellValues = Split(fileLines(i), " ")

'Write each cell value to a separate row
For j = LBound(cellValues) To UBound(cellValues)
Cells(i + 1, j + 1).Value = cellValues(j)
Next j
Next i
End Sub

回答No.4

kkkkkm

> スペースの数（１つ、２つ）関係なく貼り付けられるには、どこを修正すればよろしいでしょうか？

以下の部分を
tmp = Split(stream.ReadLine, " ")
こちらに変更してください。
tmp = Split(Application.WorksheetFunction.Trim(stream.ReadLine), " ")

回答No.3

kkkkkm

> ご指摘頂いた箇所ですが、
> 「セルC1」となります。

でしたらNo.1のコードでいけると思います。

回答No.2

kkkkkm

No.1では

> 例)セルA1に
> AAAが貼り付けられる
> セルB1に
> BBBが貼り付けられる
> セルC2に
> CCCが貼り付けられる

「セルC2に」は「セルC1に」だと考えています。
「セルC2に」が正しくてC列だけ一つ下に記載するのでしたら

For mCol = 1 To UBound(tmp) + 1
Cells(mRow, mCol).Value = tmp(mCol - 1)
Next

を

For mCol = 1 To UBound(tmp) + 1
If mCol = 3 Then
Cells(mRow + 1, mCol).Value = tmp(mCol - 1)
Else
Cells(mRow, mCol).Value = tmp(mCol - 1)
End If
Next

に変更

C列以降は全て一つ下に記載するのでしたら

For mCol = 1 To UBound(tmp) + 1
If mCol >= 3 Then
Cells(mRow + 1, mCol).Value = tmp(mCol - 1)
Else
Cells(mRow, mCol).Value = tmp(mCol - 1)
End If
Next

に変更してください。

補足

回答ありがとうございます。
ご指摘頂いた箇所ですが、
「セルC1」となります。