ser********

2020/11/28 8:58

33回答

同一フォルダにある複数のテキストファイル（メモ帳）を一括でエクセルに取り込みたいです。

同一フォルダにある複数のテキストファイル（メモ帳）を一括でエクセルに取り込みたいです。 テキストファイルは改行なしのもので、 エクセルへのまとめ方は テキストファイル１ テキストファイル２ テキストファイル３ というようにA列に１行２行３行と並んでいくようにまとめたいです。 エクセルのマクロなどでテキストファイルが入っているものを読み込み エクセルにまとめたいです。 処理する量は３００ファイルをまとめるという作業をしたいです。 ご教示よろしくお願いいたします。

Excel | Visual Basic・33閲覧・xmlns="http://www.w3.org/2000/svg">100

ベストアンサー

0

Prometheus

2020/11/28 14:37

マクロを走らせているブックが保存されているフォルダ内の「txt」ファイルを読み込みます。 なお、４行目の「m = "Shift-JIS" '"UTF-8" "Unicode"」で、これから読み込むテキストファイルの「文字コード」を設定しています。 今は、「Shift-JIS（ANSI）」ですが、ここを「m = "UTF-8"」にすれば、「UTF-8（BOM付き）」に、「m = "Unicode"」にすれば、「UTF-16LE（BOM付き）」に対応します。 また、最後に不要な改行が入る場合は、１７行目 Cells(r, "A").Value = x を Cells(r, "A").Value = Left(x, Len(x) - 1) に変えれば、最後の不要な改行は出力されません。 Sub Sample() Dim m As String, p As String Dim f As String, x As String, r As Long m = "Shift-JIS" '"UTF-8" "Unicode" p = ThisWorkbook.Path f = Dir(p & "\*.txt") r = 0 Do Until f = "" With CreateObject("ADODB.Stream") .Type = 2 .Charset = m .Open .LoadFromFile p & "\" & f x = .ReadText(-1) .Close r = r + 1 Cells(r, "A").Value = x End With f = Dir() Loop End Sub 簡単な説明です。 m = "Shift-JIS" '"UTF-8" "Unicode" これから読み込むテキストファイルの「文字コード」を設定しています。 p = ThisWorkbook.Path マクロを走らせているブックが保存されているフォルダを「p」に入れています。 f = Dir(p & "\*.txt") そのフォルダ内の拡張子が「txt」のファイルの情報を「f」に入れています。 r = 0 行カウント用変数の初期化。 Do Until f = "" 「f」の内容が空っぽになるまで、繰り返します。 With CreateObject("ADODB.Stream") 「Shift-JIS」だけでなく、「UTF-8」や「Unicode」に対応するための機能を設定しています。 .Type = 2 「テキスト」ファイルとして処理。 .Charset = m 「文字コード」を設定。 .Open 開く準備。 .LoadFromFile p & "\" & f テキストファイルを１つずつ開いています。 x = .ReadText(-1) 全行を読み込んで「x」に入れています。 .Close 閉じています。 r = r + 1 １行カウント。 Cells(r, "A").Value = x 列「A」の１行目から今読み込んだ内容を書き込んでいます。 End With f = Dir() Loop を、繰り返しています。

ThanksImg質問者からのお礼コメント

無事解決できました。 ありがとうございました。 他の方もマクロを書いていただいてありがとうございました。

お礼日時：2020/11/29 15:31

その他の回答（2件）

0

tra********

カテゴリマスター

2020/11/28 11:19

>A列に１行２行３行と並んでいくようにまとめたい テキストファイルの文字数は、セル内の許容文字数（32,767 文字）を超えないということですよね？ C:\HogeHoge\Hoge\に対象ファイルがある場合の例です。 Sub sample() Const cFld As String = "C:\HogeHoge\Hoge\" Dim rng As Range, xFile As String, i As Long Application.ScreenUpdating = False Set rng = Worksheets.Add.Range("A1") xFile = Dir(cFld & "*.txt") Do While xFile <> "" With Workbooks.Open(cFld & xFile) .Worksheets(1).Range("A1").Copy rng.Offset(i) i = i + 1 .Close False End With xFile = Dir() Loop rng.EntireColumn.AutoFit Application.ScreenUpdating = True End Sub

0

gla********

2020/11/28 9:39

フォルダ指定して処理する方法です。100ファイルだと処理時間がかかると思います。この方法は一括読み込み方式です。ので、読み込み時の行数指定はできません。また、転記先のファイル毎の区切りはありません。 Sub test() Dim fs As New FileSystemObject Dim ReadStr() As String Dim TargetFolder As String: TargetFolder = "C:\Users\○○\Desktop\△△\" 'フォルダ指定 Dim TargetSheet As Worksheet: Set TargetSheet = Worksheets(1) Dim NowRow As Integer: NowRow = 1 TargetSheet.Cells.Clear '全セルクリア For Each f In fs.GetFolder(TargetFolder).Files ReadStr = Read_Data(f.path) '読み込んだ内容をシートへ出力 For Each D In ReadStr If Len(D) > 0 Then TargetSheet.Cells(NowRow, 1) = D NowRow = NowRow + 1 End If Next D Next f MsgBox ("作業完了") End Sub 'テキストデータ一括読み込み Function Read_Data(ReadPath As String) As String() Dim tmp As String Dim fs As New FileSystemObject Dim ts As TextStream Set ts = fs.OpenTextFile(ReadPath, ForReading) If Not ts Is Nothing Then tmp = ts.ReadAll '一括読込 End If ts.Close Set ts = Nothing Set fs = Nothing Read_Data = Split(tmp, vbCrLf) End Function