特定フォルダ内のテキストファイルの内容を全てエクセルに書き出す方法

エクセルのマクロを使用し、以下の内容を行う方法をご教示いただきたいです。

テキストファイル の中身をエクセルに入れ、シート名はファイルの名前にします。
ファイルの数だけ同じ名前のシートが作成される、というイメージです。

①１つのフォルダに格納されているテキスト（.txt）を上から順に、
　テキストファイルの中身を一行ずつエクセルに書きこむ
②エクセルに書き込む際、テキストファイル名を、エクエルシートの名前にする
③テキストファイル の中身は、改行コードが入っているため、
　手でコピーし、張り付けると、１つの列に上から順に反映される。
　そのようにエクエルに貼り付けたいです。
④テキストファイルの中にあるテキスト量はファイルによってまちまち

複雑で、自分で挑戦したときにはエラーも起きず何も発生せずでした。。。

どうぞよろしくお願い致します。

No.1 回答者： Qchan1962 回答日時： 2020/05/31 06:33

おはようございます。

＞手でコピーし、張り付けると、１つの列に上から順に反映される。、、

上手く伝わっていませんが、改行コードとは何を指しているのかなーと思いますが
テキスト（.txt）と言う事で、抽出のやり方は、色々ありますが、あまり気にせず下記をサンプルにしました。

よく使うので、ファイル抽出部分とデータ抽出部分が分れています。2つ例を上げますが
元々データやCSVに使っているものなので、ほぼコピペの為、少し大げさかも知れません。
シート名は、既存にある場合、自動作成名になります。
シート作成は、メモリ依存ですが、1000ファイルとかある場合は、リミットを設定した方が良いかも知れません。

データ抽出部分は、簡単な
　Open TrgFile For Input As #1
　Do Until EOF(1)
　　Line Input #1, fileLine
　　Cells(i + 1, 1) = fileLine
　　　i = i + 1
　　Loop
　　Close #1
で良いかもです。


サンプル
Sub InTxt_NewSheets()
Dim newWs As Worksheet
Dim i As Long, j As Long
Dim filePath As String, fileName As String
Dim Extension As String, Array_file() As String
　　Extension = ".txt"
　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　　.InitialFileName = CreateObject("WScript.Shell").SpecialFolders("desktop")
　　　　If .Show = True Then
　　　　　　filePath = .SelectedItems(1) & "\"
　　　　End If
　　End With
　　If filePath = "" Then Exit Sub
　　fileName = Dir(filePath & "*" & Extension)
　　Do While fileName <> ""
　　　　ReDim Preserve Array_file(i)
　　　　Array_file(i) = fileName
　　　　i = i + 1
　　　　fileName = Dir()
　　Loop
　　For j = LBound(Array_file) To UBound(Array_file)
　　　　Set newWs = Worksheets.Add(After:=Sheets(Worksheets.Count))
　　'　　　　Call OpenDB(filePath, Array_file(j), newWs)
　　　　Call QTRF(filePath, Array_file(j), newWs)
　　　　On Error Resume Next　　'同名シートがあると1004の為　On Error Resume Next (name Sheet？
　　　　newWs.Name = Array_file(j)
　　Next j
　　MsgBox ("終了しました")
End Sub

’クエリテーブル
Private Sub QTRF(filePath As String, fileName As String, newWs)'上のままだとこれが実行されます。
　　With newWs.QueryTables.Add(Connection:="TEXT;" & _
　　filePath & fileName, Destination:=newWs.Range("A1"))
　　　　.TextFilePlatform = 932
　　　　.TextFileParseType = xlDelimited 'xlFixedWidth
　　　　.RefreshStyle = xlOverwriteCells
　　　　.Refresh
　　　　.Delete
　　End With
End Sub

'Private Sub InTxt_NewSheets()の
Call OpenDB(filePath, Array_file(j), newWs)　'有効にする
Call QTRF(filePath, Array_file(j), newWs)削除または無効にすると下記で処理されます。 .ReadText(-1)だと改行が無視され1セルに入ります。-2だと上と同じ結果

'通常、 .ReadText　を　Splitなどで加工して出力する場合に使う
Private Sub OpenDB(filePath, fileName, newWs)
　　Dim i As Long
　　With CreateObject("ADODB.Stream")
　　　　.Charset = "Shift_JIS" ' "UTF-8"
　　　　.Open
　　　　.LoadFromFile filePath & fileName
　　　　Do Until .EOS
　　　　　　newWs.Cells(i + 1, 1) = .ReadText(-1) '-1：１行　-2 LF行単位
　　　　　　i = i + 1
　　　　Loop
　　　　.Close
　　End With
End Sub

どちらにも該当しない結果をお望みの場合は、改行コード、テキストの内容（デモ）
正しく実行された場合の、サンプルを提示するのが良いと思います。

取り敢えず、ありあわせです。