Excel.VBA テキストファイルを指定行数からの読み込む

例えば
テキストファイルは１００個あります。
内容の書式は全部同じです。
１００個のファイルの中に５０行目と８０行目のデータが欲しいです。
ファイル名はDATA１～DATA100
ファイル名もほしいです。
中身は：
...
あいうえおかきくけこ　　'50行目
...
...
らりるれろやゆよ　　　　'80行目
...
↓↓↓↓

ファイル名　　　　　50行目　　　　　　　　　80行目
DATA1　　　　あいうえおかきくけこ　　らりるれろやゆよ
DATA2　　　　あいうえおかきくけこ　　らりるれろやゆよ
DATA3　　　　あいうえおかきくけこ　　らりるれろやゆよ
DATA4　　　　あいうえおかきくけこ　　らりるれろやゆよ


こういうようにExcel に入れてほしいです。
色んな方法でやってみましたが、うまく行きませんでした。
VBAの知識が不足の為、勝手を申しますが詳しくご教示頂けると幸いです。

No.1 ベストアンサー 回答者： Qchan1962 回答日時： 2020/04/07 19:08

手持ちのコードが改造できそうでしたのでアドバイスと言うより、作成しました。

コードに付いては少々長いので、各コードなどの説明は、省略させていただきます。

テキストファイルに80行満たないものがあるとエラーになり（一応Nextしている）ファイル名のみ
出力されます。
出力先は、アクティブシートのABC列です。
100ファイル位なら問題はないと思います。

プロセスは、対象が入っているフォルダを選択
フォルダ内のtxtファイルを配列に入れ、名前順にソート
順番に対象を開き　FSOでターゲットLine迄SkipLineで飛ばし目的に達したら
Variant配列に書き込みSplitでセルに出力しています。

スタートプロシージャは手持ち改造の為、　Sub FileIn_Sort()　です。
必要に応じ変更してください。

Option Explicit
'ソートのためのAPI読み出し宣言
Declare PtrSafe Function StrCmpLogicalW Lib "SHLWAPI.DLL" _
　　　　(ByVal lpStr1 As String, ByVal lpStr2 As String) As Long
Sub bubble_sort_API(ByRef StrArr() As String) 'APIでのソート
Dim i As Long, j As Long
Dim tmp As String
　　For i = LBound(StrArr) To UBound(StrArr)
　　　　For j = i To UBound(StrArr)
　　　　　　If StrCmpLogicalW(StrConv(StrArr(i), vbUnicode), StrConv(StrArr(j), vbUnicode)) > 0 Then
　　　　　　　　tmp = StrArr(i)
　　　　　　　　StrArr(i) = StrArr(j)
　　　　　　　　StrArr(j) = tmp
　　　　　　End If
　　　　Next j
　　Next i
End Sub
Sub FileIn_Sort()　’スタート
　　Dim i As Long, ix As Long
　　Dim Folder_path As String
　　Dim MergeWorkbook As String, FileType As String
　　Dim fileName() As String
　　i = 1
　　If Application.FileDialog(4).Show = True Then
　　　　Folder_path = Application.FileDialog(4).SelectedItems(1)
　　　　FileType = "\*.txt"
　　End If
　　MergeWorkbook = Dir(Folder_path & FileType)
　　'---ファイル抽出 start
　　Do
　　　　ReDim Preserve fileName(i)
　　　　fileName(i) = MergeWorkbook
　　　　i = i + 1
　　　　MergeWorkbook = Dir()
　　Loop Until MergeWorkbook = ""
　　'---ファイル抽出 stop
　　Call bubble_sort_API(fileName())　　　　'ソート呼び出し
　　'API昇順ファイル名（配列）で処理
　　For ix = 1 To UBound(fileName)
　　　　'　　メイン処理
　　　　Call Trg_ReadLine(Folder_path, fileName(ix))
　　Next
　　MsgBox ("終了しました")
End Sub

Sub Trg_ReadLine(filepath As String, fileName As String)　’メイン処理
　　'ファイルの指定行を読込
　　Dim searchLineMax As Long: searchLineMax = 80
　　Dim TargetLine1 As Long: TargetLine1 = 50
　　Dim TargetLine2 As Long: TargetLine2 = 80
　　Dim i As Long, cellRow As Long
　　Dim fso As Object, ts As Object
　　Dim StrDate As Variant
　　Set fso = CreateObject("Scripting.FileSystemObject")
　　Set ts = fso.OpenTextFile(filepath & "\" & fileName)　　' ファイルを開く
　　StrDate = fileName
　　On Error Resume Next　　'行数がない場合の対策
　　For i = 1 To searchLineMax
　　　　If i = TargetLine1 Then StrDate = StrDate & "," & ts.ReadLine
　　　　If i = TargetLine2 - 1 Then
　　　　　　StrDate = StrDate & "," & ts.ReadLine
　　　　　　Exit For
　　　　End If
　　　　ts.SkipLine
　　Next i
　　With ActiveSheet
　　　　cellRow = .Cells(Rows.Count, 1).End(xlUp).Row
　　　　.Range("A" & cellRow + 1).Resize(, 3) = Split(StrDate, ",")
　　End With
　　ts.Close
　　Set ts = Nothing
End Sub

この回答へのお礼

ご回答ありがとうございます。
正しく取り出しました。

本当にありがとうございました

お礼日時：2020/04/08 10:48

No.3 回答者： iothes00 回答日時： 2020/04/08 09:23

文字化けする場合は

i = 2
For Each myF In CreateObject("Shell.Application").Namespace(ActiveWorkbook.Path & "\").Items
If Right(myF.Name, 4) = ".txt" Then
Range("A" & i) = myF.Name
With CreateObject("ADODB.Stream")
.Charset = "SHIFT_JIS"
.Open
.LoadFromFile (ActiveWorkbook.Path & "\" & myF.Name)
textline = .readText(-1)
splitt = Split(textline, vbCrLf)
Range("B" & i) = splitt(49)
Range("C" & i) = splitt(79)
.Close
End With
i = i + 1
End If

No.2 回答者： iothes00 回答日時： 2020/04/08 09:22

エクセルと同じ場所にtxtを置きます

i = 2
For Each myF In CreateObject("Shell.Application").Namespace(ActiveWorkbook.Path & "\").Items
If Right(myF.Name, 4) = ".txt" Then
Range("A" & i) = myF.Name
With CreateObject("ADODB.Stream")
.Charset = "UTF-8"
.Open
.LoadFromFile (ActiveWorkbook.Path & "\" & myF.Name)
textline = .readText(-1)
splitt = Split(textline, vbCrLf)
Range("B" & i) = splitt(49)
Range("C" & i) = splitt(79)
.Close
End With
i = i + 1
End If

この回答へのお礼

ご回答ありがとうございます。
やってみましたが、うまく行きませんでした。
subとnextを補足しましたが、データは全然入れません。

お礼日時：2020/04/08 10:51