複数のテキストファイルをエクセルの１シートに連続取り込み

Question

タイトルのようにテキストファイルがD:\にあります
１シートに連続して最終行を取得し張り付けたいのですが
いろいろ探してみてるのですが理想のサンプルがありません
シート単位の取得はあるのですが連続したものを教えていただけないでしょうか？
素人なのでドライブ変更ぐらいしかできません
宜しくお願い致します。

Qchan1962 · Accepted Answer

Sub dat_import()の場合
' On Error Resume Next を　On Error Resume Next　’を削除

Sub CSV_Extraction_comma()の場合
Dim first_path As String, Extension As String, St_Name As String
On Error Resume Next　を追加
Extension = "txt"

アラートは出ませんが、止まる事もなくなります。
バインディングで躓くのだから、おそらく何も分からないと思いますが、
＞後輩たちに引き継ぐ際に
そのように思うなら、追加するコードなど他にもありますよ。
あなたの為に付けてないのですよ。分かりますか。

いずれにしても、あなたが、ここに質問する語句をそのままGoogle先生に聞いて
自らが理解してデバックしながら作らないと、知識を得ることは出来ません。
＞いろいろ探してみてるのですが理想のサンプルがありません
それは、あなたに理想がないからだと理解出来ました。

なかなかいいバイクですよね。KZ900SR　デモ体力的にもう乗れません。

Qchan1962 · Answer

すみません。
遅延（実行時）にバインディングにしようか迷ったのですが、、

参照設定は、こちらを参考にしてみてください。
https://www.atmarkit.co.jp/ait/articles/1703/14/news022.html

Qchan1962 · Answer

K-Z900RS様
＃６に関して、論調が不適切で申し訳ありませんでした。

データファイルについては、幅が広くその仕様により様々です。単純にテキストとして抽出できるものとは理解しておりません。
ただ、Excelに取得されることを前提に作られたものであれば、正しく抽出する事も成形する事も、もちろん可能ですね。
であれば、dat拡張子のものもレコード（Byte）単位でなく行単位が良いでしょう。従って、txt同様のプロセスで抽出できると思います。

一応、ご理解いただきたいのは、
＞タブ、カンマ、一つ以上の空白、の選択式で取り込んでいます
＞txtファイルの内容はタブ区切りで100行ほどdatファイルは不規則なスペース区切りですが全角,半角,記号,スペースで200桁ぐらいで
＞エクセルに取り込んだ後にMIDB関数で区切ってます
とあるので、その部分（データ処理）は、すでに出来ており、理解されていると解釈してファイル読み込み部分を回答されているのだと思います。
また、CSV、TXTファイルの抽出方法はプログラムをする方の経験や好み、仕様も関係します。また、ADODBを活用したり、、、多くの方法があります。
なので、私はめんどくさい（後からこうしたいああしたい、出来るけど、、発生率高い）ので、明確でないと回答しにくいですね。

＞いろいろ探してみてるのですが理想のサンプルがありません
そんなはずは、ないと思いますよ。

昔、作った物の寄せ集めですが、ご希望の処理は出来るかとコード内の　Replaceで仕様に合わせてください。
txtファイルカンマ区切り専用です。該当処理を変えれば、色々出来るかと思います。
TS.ReadAllで処理しようかとも思いましたが、これも一行目はいらないとのことでやめました。処理は数十倍以上遅くなります。

CSVも作ろうかと思いましたが、
＞一つ以上の空白、の選択式で取り込んでいます
の意味が解らないので、やめました。

おそらく、このサンプルも理想のサンプルではないと思いますが、、シンプルな流れにしましたので学習できるかと思います。
（時間の関係上、寄せ集めなので変な個所がありますが、問題なく処理されるかと）
Option Explicit
Sub CSV_Extraction_comma()
Dim FSO As FileSystemObject            ' Microsoft Scripting Runtime 参照
    Set FSO = New FileSystemObject
    Dim TS As TextStream
    Dim i As Long, GYO As Long, S As Long, FG As Long
    Dim strREC As String               '読み込みテキスト 行データ
    Dim tx_val As Long, tmp As Variant
    Dim Folder_Path As String, f As Object
    Dim first_path As String, Extension As String, St_Name As String
    
    Extension = "txt"
    St_Name = ActiveSheet.Name         '"Sheet1"
    first_path = "D:\"                 'CreateObject("WScript.Shell").SpecialFolders("desktop")

With Application.FileDialog(msoFileDialogFolderPicker)
　　　.InitialFileName = first_path
　　　If .Show = True Then
　　　　Folder_Path = .SelectedItems(1) & "\"
　　　End If
　End With
　If Folder_Path = "" Then Exit Sub

With FSO
　　For Each f In .GetFolder(Folder_Path).Files
　　FG = 0
　　　If LCase(.GetExtensionName(f)) = Extension Then
　　　　Set TS = FSO.OpenTextFile(Folder_Path & f.Name, ForReading)
　　　　　GYO = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
　　　　　Do Until TS.AtEndOfStream
　　　　　　　strREC = TS.ReadLine
　　　　　　　strREC = Replace(Replace(Replace(Replace(strREC, vbLf, ""), "  ", ""), """", ""), vbCr, "")
　　　　　　　S = 0
　　　　　　　If FG > 0 Then
　　　　　　　　If InStr(strREC, ",") > 0 Then
　　　　　　　　　For i = 1 To Len(strREC)    'カンマ区切りデータ限定
　　　　　　　　　　If Mid(strREC, i, 1) = "," Then S = S + 1
　　　　　　　　　Next i
　　　　　　　　　For tx_val = 0 To S
　　　　　　　　　　ReDim tmp(tx_val)
　　　　　　　　　　tmp = Split(strREC, ",")
　　　　　　　　　　Cells(GYO, tx_val + 1).Value = tmp(tx_val)
　　　　　　　　　Next tx_val
　　　　　　　　Else
　　　　　　　　End If
　　　　　　　　GYO = GYO + 1
　　　　　　End If
　　　　　　FG = FG + 1
　　　　Loop
　　　End If
　　Next f
　End With
　TS.Close
　Set TS = Nothing
　Set FSO = Nothing
End Sub

Qchan1962 · Answer

datファイルの一行目の意味が分かりません。
Byteでなくて良いのですか？それ、dat？txtって書いてあるし、
どんなデータが入ってるの？普通にTxtやCsvに変更できるファイルなのですか？
txtで読めるの？
そもそも引っ掛かっていた事を指摘しますが、
今使ってるのはtxt,dat,csvの選択式です。
同じルーチンを通すつもり？
別物ですよね。

後出しじゃんけんヤダと言ってますし、
つまり無知な質問に付き合えないか、後からやりたい事を
ヒントを得てから構想するやからに付き合えませんよ

＞素人なのでドライブ変更ぐらいしかできません
自覚があるなら、するべきことは、他にあるのでは？

ご質問のそれが出来ても、どうせ活用できないし、
勉強してから質問しなさい。理解できないでしょし、

Qchan1962 · Answer

＃４の訂正をさせてください。しっかり検証しなかった事を悔やんでます。再確認してよかったです。
下記に訂正コードを示します。

Option Explicit
Sub dat_import()
Dim i As Long
Dim Folder_Path As String, f As Object
Dim Extension As String, ArrFile() As String
'    Dim File_Name As String, first_path As String
    '    On Error Resume Next
    Extension = "dat"
    Folder_Path = "D:\"
    
'        first_path = CreateObject("WScript.Shell").SpecialFolders("desktop")
'        With Application.FileDialog(msoFileDialogFolderPicker)
'            .InitialFileName = first_path
'            If .Show = True Then
'                Folder_Path = .SelectedItems(1) & "\"
'            End If
'        End With
'        If Folder_Path = "" Then Exit Sub
    With CreateObject("Scripting.FileSystemObject")
        For Each f In .GetFolder(Folder_Path).Files
            If LCase(.GetExtensionName(f)) = Extension Then
                i = i + 1
                ReDim Preserve ArrFile(i)
                ArrFile(i) = f.Name
            End If
        Next f
    End With
Call File_write(Folder_Path, ArrFile)
Cells.WrapText = False
End Sub

Sub File_write(Folder_Path, ArrFile)
Const Record_length = 500
Dim i As Long, j As Long, FirstRow As Long, n As Long
Dim Record(Record_length - 1) As Byte
Dim Records_count
FirstRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1    'シートの一行目は、見出し行（又は空白）になります。
    n = FreeFile
    With ThisWorkbook.Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With
    For j = 1 To UBound(ArrFile)
        Open Folder_Path & "\" & ArrFile(j) For Binary As n
        Records_count = (LOF(1) / Record_length)
        For i = 1 To Records_count
            Get n, , Record
            Cells(FirstRow, 1).Offset(i - 1).NumberFormatLocal = "@"
            Cells(FirstRow, 1).Offset(i - 1).Value = StrConv(Record, vbUnicode)
        Next i
        Close n
        FirstRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
    Next
    With ThisWorkbook.Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
End Sub

すみません。

Qchan1962 · Answer

こんにちは、dat拡張子のファイルについては、ご存知の事と思います。余計な説明は割愛しますが
ファイルの内容によっては、文字化けや抽出できない場合もあります。
＞このエクセルマクロでｄａｔファイルも同じように複数ファイルを連続読み込みしたいのですが区切りもなく
そのままの取り込み方法も教えていただけないでしょうか？

参考まで
コメント部分のコードは、デバック、テスト時に使用したコードです。
テストする時に活用してください。
新規Bookでテストしてください。

Sub dat_import()
Const Record_length = 600
Dim Records_count As Long
Dim Record(Record_length - 1) As Byte
Dim i As Long, j As Long, FirstRow As Long, n As Long
Dim Folder_Path As String, f As Object
Dim Extension As String, ArrFile() As String
'    Dim File_Name As String, first_path As String
    '    On Error Resume Next
    Extension = "dat"
    FirstRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
    'シートの一行目は、見出し行（又は空白）になります。
    Folder_Path = "D:\"
   
'        first_path = CreateObject("WScript.Shell").SpecialFolders("desktop")
'        With Application.FileDialog(msoFileDialogFolderPicker)
'            .InitialFileName = first_path
'            If .Show = True Then
'                Folder_Path = .SelectedItems(1) & "\"
'            End If
'        End With
'        If Folder_Path = "" Then Exit Sub

    With CreateObject("Scripting.FileSystemObject")
        For Each f In .GetFolder(Folder_Path).Files
            If LCase(.GetExtensionName(f)) = Extension Then
                i = i + 1
                ReDim Preserve ArrFile(i)
                ArrFile(i) = f.Name
            End If
        Next f
    End With
    n = FreeFile
    For j = 1 To UBound(ArrFile)
        Open Folder_Path & "\" & ArrFile(j) For Binary As n
        Records_count = (LOF(1) / Record_length)
        For i = 1 To Records_count
            Get n, , Record
            Cells(FirstRow, 1).Offset(i - 1).NumberFormatLocal = "@"
            Cells(FirstRow, 1).Offset(i - 1).Value = StrConv(Record, vbUnicode)
        Next i
        Close n
        Cells.WrapText = False
    Next
End Sub

Const Record_length = 600　’レコード数の設定です。目的に合わせ変更してください。

Binaryで抽出し、vbUnicode（Windowsのみ）で書き出しています。

対象のdatファイルの内容により、変更が必要かもしれません。

Open ステートメントBinaryについて　https://docs.microsoft.com/ja-jp/office/vba/language/reference/user-interface-help/open-statement

StrConv 関数について　https://docs.microsoft.com/ja-jp/office/vba/language/reference/user-interface-help/strconv-function

＞MIDB関数で区切ってます
これもどの様なByte区切りか気になりますが、、

他の形式については、すでにコードもあるので、、

不明な点がありましたら、補足でお願いします。

WindFaller · Answer

自分のテキストファイルで試しにやってみました。

>１シートに連続して最終行を取得し張り付けたい
「最終行のみ」という解釈です。
一応、サンプルまでです。現実は、そんなに簡単にはいかないかもしれません。
また、ReadAllを使っている以上、ファイルの大きさにより、メモリ限界があります。

'//標準モジュール
Sub CheckLstline()
　Dim objFS As Object
　Dim objText As Object
　Set objFS = CreateObject("Scripting.FilesystemObject")

　Dim FName As String, MyPath As String
　MyPath = "D:\Data\Text" '必ず末尾には、￥を忘れないこと

　Dim myArray '配列要変数
　Dim i As Long
　ReDim myArray(2000) 'ファイルの限界数=2000

　Dim arBuf
　Dim buf As String
　Dim j As Long, n

　FName = Dir(MyPath & "*.txt", vbNormal) 　'Dirリスト
　Do While FName <> ""
　　If FName <> "." And FName <> ".." Then
　　　If (GetAttr(MyPath & FName) And vbNormal) = vbNormal Then
　　　　myArray(i) = FName
　　　　i = i + 1
　　　　If i > UBound(myArray) Then Exit Do '限界数
　　　End If
　　End If
　　FName = Dir
　Loop
　For Each n In myArray
　　If n <> "" Then
　　　Set objText = objFS.OpenTextFile(MyPath & n) 'shift-jis
　　　'Set objText = objFS.OpenTextFile(MyPath & n, , , -1) 'unicode
　　　arBuf = Split(objText.ReadAll, vbCrLf) ''Return Code =Cr+Lf
　　　buf = arBuf(UBound(arBuf))
　　　　j = j + 1
　　　　Cells(j, 1).Value = buf '出力データ
　　　　objText.Close
　　　　buf = ""
　　　If j > i Then Exit For 'j は行数、i は配列index+1　--出力数調整可能
　　End If
　Next n
End Sub

fujillin · Answer

こんにちは

内容的に不明な点が多いけれど、サンプルがあれば良いのなら多少はそれっぽいかも。

Sub Sample()
Dim wb As Workbook
Dim ds As Worksheet
Dim sr As Range
Dim rw As Long, rwMax As Long
Dim fName As String
Dim flg As Boolean

const folderPath = "D:\"

Set ds = ActiveSheet
ds.Cells.ClearContents
ds.Cells.UnMerge
fName = Dir(folderPath & "*.txt")
rwMax = 1
flg = True

Application.ScreenUpdating = False

While flg And fName <> ""
　ds.Cells(rwMax, 1).Value = "◆◆ file name: " & fName
　rwMax = rwMax + 1
　Workbooks.OpenText Filename:=folderPath & fName, _
　　　DataType:=xlDelimited, Comma:=True, Space:=True, Tab:=ture

Set wb = ActiveWorkbook
　Set sr = ActiveSheet.UsedRange
　If rwMax + sr.Rows.Count >= Rows.Count Then
　　MsgBox "行数溢れのため中断します"
　　flg = False
　Else
　　sr.Copy Destination:=ds.Cells(rwMax, 1)
　　rwMax = rwMax + sr.Rows.Count
　End If
　wb.Close SaveChanges:=False
　fName = Dir()
Wend
Application.ScreenUpdating = True

MsgBox "終了"
End Sub

※ 後出しじゃんけんは嫌いなので、後は適当にどうぞ。

Qchan1962 · Answer

VBAでよろしいのでしょうか？
txtファイルやcsvファイルの抽出は、VBAでは必要に迫られる事が多く、
ある程度のスキルの方は、皆さんご存知かと思います。
テキストファイルやCSVファイルの抽出は、以外に奥が深いです。

情報や回答が付かないのは、皆さんは、どの様なテキストか分からない為と思われますよ。
通常？、テキストファイルをExcelシートに読み込む（抽出）時は、セルに分割？しデータとして
活用する事が多いですね。したがって、カンマ区切りのTxtファイルとか、タブ区切りとか
使用目的とか知りたいのではないでしょうか？

連続して、最終行以降に追記して行く事はVBAでは、難しい事ではありません。
読み込みは、ファイルシステムオブジェクトのFSO.OpenTextFileとか、、方法は、色々あります。
1行単位でA列に抽出するだけであれば、容易です。

あなたの言う理想をもう少し具体的に示してください。
そうすれば、有益な情報が得られると思いますよ。。。

複数のテキストファイルをエクセルの１シートに連続取り込み

Sub dat_import()の場合

すみません。

K-Z900RS様

datファイルの一行目の意味が分かりません。

＃４の訂正をさせてください。

こんにちは、dat拡張子のファイルについては、ご存知の事と思います。

自分のテキストファイルで試しにやってみました。

こんにちは

VBAでよろしいのでしょうか？

似たような質問が見つかりました

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

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

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

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

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