テキスト情報を全摘出するエクセルマクロ

質問

すみません、教えてください。

とあるフォルダにテキストファイルが複数(100ファイルぐらい)入っています。ファイル名は連番が付いています。
中身は文字数・改行数共にランダムな英文となってます。

これをテキストファイルの名称順に、
所定のエクセルファイルのエクセルシートの1行目から順に並べていきたいです。
結果的に、複数のテキスト内情報を1つのシートにすべて1行目から順番に貼り付けた状態に仕上げたいということです。

教えていただけると助かります。
宜しくお願いします。

回答No.1

kkkkkm · ベストアンサー

以下で試してみてください。Testを実行してください

Sub Test()
Dim mData As Object
Dim buf As Variant
Dim LastRow As Long, LastRowWs2 As Long, i As Long
Dim Ws1 As Worksheet, Ws2 As Worksheet

Set Ws1 = Sheets("Sheet1") 'データを書き込むシート
Set Ws2 = Sheets("Sheet2") 'ファイル一覧を作成するシート

Ws1.Range("A:A").ClearContents
Ws2.Range("A:A").ClearContents

Const Path As String = "C:\Ok\test\teset\" 'txtファイルのあるフォルダ指定

Call FileNameSort(Ws2, Path)

Set mData = CreateObject("ADODB.Stream")

mData.Charset = "utf-8"

LastRowWs2 = Ws2.Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRowWs2
mData.Open
mData.LoadFromFile Path & Ws2.Cells(i, "A").Value
buf = Split(mData.ReadText, vbLf)
If Ws1.Range("A1").Value = "" Then
LastRow = 0
Else
LastRow = Ws1.Cells(Ws1.Rows.Count, "A").End(xlUp).Row
End If
Ws1.Cells(LastRow + 1, "A").Resize(UBound(buf), 1).Value = WorksheetFunction.Transpose(buf)
mData.Close
Next

Set Ws1 = Nothing
Set Ws2 = Nothing
Set mData = Nothing

End Sub

Sub FileNameSort(ByRef Ws2 As Worksheet, ByVal Path As String)
Dim buf As String, mRow As Long
buf = Dir(Path & "*.txt") 'txtファイルだと思うので拡張子をtxtにしてます
'
With Ws2
Do While buf <> ""
mRow = mRow + 1
.Cells(mRow, 1) = buf
buf = Dir()
Loop
.Range("A1:A" & mRow).Sort Key1:=.Range("A1"), Order1:=xlAscending
End With
End Sub

お礼

考えていた仕様通りのマクロでした。色々伝わりにくいところもありお気遣いもいただき本当にありがとうございました。非常に助かりました。

Powered by GRATICA

回答No.3

kkkkkm

回答No.1の補足です。

> Set Ws2 = Sheets("Sheet2") 'ファイル一覧を作成するシート

自分で一覧を作成しないといけないとも取れるコメントのような気がしたので

ファイル一覧は指定したシートにマクロで作成しますのでシートだけ指定してください。

回答No.2

kkkkkm

回答No.1の補足です。

もし、一つのファイル分を一つのセルに入れるのでしたら

For i = 1 To LastRowWs2
mData.Open
mData.LoadFromFile Path & Ws2.Cells(i, "A").Value
buf = Split(mData.ReadText, vbLf)
If Ws1.Range("A1").Value = "" Then
LastRow = 0
Else
LastRow = Ws1.Cells(Ws1.Rows.Count, "A").End(xlUp).Row
End If
Ws1.Cells(LastRow + 1, "A").Resize(UBound(buf), 1).Value = WorksheetFunction.Transpose(buf)
mData.Close
Next

上記の部分を以下に変更してください。

For i = 1 To LastRowWs2
mData.Open
mData.LoadFromFile Path & Ws2.Cells(i, "A").Value
If Ws1.Range("A1").Value = "" Then
LastRow = 0
Else
LastRow = Ws1.Cells(Ws1.Rows.Count, "A").End(xlUp).Row
End If
Ws1.Cells(LastRow + 1, "A").Value = mData.ReadText
mData.Close
Next