VBA：テキストファイルの抽出について教えてください

テキストファイルの抽出について2点教えてください。
スペック
・Excel2013
・Windows10
①
テキストファイルの内容をコピーするコピー元ファイルを
起動エクセルを置いたフォルダ内のすべてのフォルダから.txtファイルを
抽出したいのですが、下記のコードをどのように変えればいいでしょうか。

Sub TextFiles()
Const DirName = "C:\\\\"

Dim fs, dir, fc, f1, stream As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set dir = fs.GetFolder(DirName)
Set fc = dir.Files
For Each f1 In fc
If LCase(fs.GetExtensionName(f1.Name)) = "txt" Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
Sheets(Worksheets.Count).Name = f1.Name
Set stream = f1.OpenAsTextStream
Do While stream.AtEndOfStream <> True
Cells(stream.Line, 1) = stream.ReadLine
Loop
stream.Close
End If
Next
End Sub
②
テキストファイルの抽出部分をユーザーフォームで指定したいのですが可能でしょうか？
例
15行目～20行目
”。”から”。”
VBAについてはまだまだ勉強中なのでご迷惑と思いますが
詳しく教えて頂ければ有難いです。
宜しくお願いいたします。

No.3 回答者： WindFaller 回答日時： 2018/02/01 19:59

繰り返すようですが、基本的に、私は、自分の書いたVBAのコードの解説はしません。

全体的なコードの流れ以外には、よほど、自分のスタイルやパターンにあったコードを書く人出ない限りは、理解しないものだと思います。

このご質問になったコードは、もともと、VBA(for Excel)ではなく、VBScript のコードです。

私がこのテクニックを知ったのは、ずいぶん昔なのですが、それを自分なりに、VBAに移植できたのは、それを知ってから、4～5年経ってからです。

このコードはVBA由来ではありません。

VBAがどのぐらいのレベルにあるのかは分かりませんが、こういうものは、説明してどうにかなるというものではないと思うのです。もとより、VBAから一足飛びに、VBScript を理解するということが本当に可能かどうか、私には分かりかねます。VBScript自体は、もう消えつつある言語でもあるにも関わらず、それを極めている人は少ないと思います。

個々の分からない部分は、教えることはできても、全体的に詳しくは教えられませんので、悪く思わないでください。決して意地悪をしているわけではありません。ただし、あまりスッキリとした内容ではないということは間違いありません。

それと、UserFormに組み込む場合は、VBA由来のコードで行ったほうが遥かに簡単だと思います。

ところで、剣道と居合道の違いをご存知ですか？私は、耳学問というか、学生時代の友人の聞きかじりなのですが、剣道は、自分の身体で覚えなくてはなりませんが、居合道は、刀が教えてくれるといいます。VBScript とVBAも同様で、VBAは、VBA自身が教えてくれるものなのです。デバックをしながら、進んでいけば分かるはずです。

No.2 回答者： WindFaller 回答日時： 2018/01/30 23:17

>コードを書いて頂いたのに自分では難しくて

>なかなか内容が把握出来ず動かせない状態です。

構造的なことしか説明はできません。

・最初の登録フォルダーのファイルを探す
次に、再度
・フォルダーを探す
ループして、
・フォルダーのサブフォルダーを検索
・その一つの中のファイルを探す
ループに戻る

ただ、他人の作ったものというのは、よほど、同じようなスタイルを身に着けていない限りは説明しても、よくわからないはずです。ここで掲げたコードは、まだ、検証されていません。

http://oshiete.goo.ne.jp/qa/10249285.html
こちらで、同じ性質を持つコードをアップロードしました。こちらのものに修正を加えています。参考にしてみてください。

No.1 回答者： WindFaller 回答日時： 2018/01/29 16:21

こんにちは。

最初に、余計なことを書くようですが、このご質問に、なかなかレスが付かないのは、VBAでありながら、VBAではないテクニックが必要だからです。別の外部オブジェクトを利用したマクロというのは、それなりにむつかしさがあります。

①

Option Explicit
Dim objFS As Object
Dim i As Long
Sub FileSearch()
　Dim objFolder As Object
　Dim dest As String
　i = 0
　ThisWorkbook.Activate
　ActiveSheet.UsedRange.Clear
　Dim DirName: DirName = Application.DefaultFilePath & "test\"　'ユーザー設定
　Set objFS = CreateObject("Scripting.FileSystemObject")
　Set objFolder = objFS.getfolder(DirName)
　Call ShowFiles(objFolder.Files) '親
　Call ShowFolder(objFolder)
　MsgBox "終了", vbInformation
End Sub
Sub ShowFiles(ByRef objFiles)
　Dim f
　For Each f In objFiles
　If LCase(f) Like "?*.txt" Then
　 Cells(1 + i, 1).Value = f
　 i = i + 1
　 Call FSReadLine(f)
　End If
　Next
End Sub
Sub FSReadLine(ByVal fName As String)
Dim objText As Object
Dim cnt As Long
Set objText = objFS.OpenTextFile(fName)
cnt = i + 1
Do While objText.AtEndOfLine <> True
Cells(cnt, 2).Value = objText.ReadLine
cnt = cnt + 1
Loop
i = cnt
objText.Close
End Sub
Sub ShowFolder(ByVal objFolder)
　Dim objSubs As Object, oSb　'子
　Dim eaFiles As Object
　Set objSubs = objFolder.Subfolders
　For Each oSb In objSubs
　　　Set eaFiles = oSb.Files
　　　Call ShowFiles(eaFiles)
　　　Call ShowFolder(oSb)
　Next
End Sub


②
グローバル変数の fstL, endL を標準モジュールに設けて
ユーザーフォームで指定すればよいはずです。

Sub FSReadLineR(ByVal fName As String)
Dim objText As Object
Dim cnt As Long
Dim j As Long
Set objText = objFS.OpenTextFile(fName)
cnt = i + 1
j = 1
Do While objText.AtEndOfLine <> True
If j >=fstL and j <=endL then
Cells(cnt, 2).Value = objText.ReadLine
cnt = cnt + 1
End if
Loop
i = cnt
objText.Close
End Sub

この回答へのお礼

わざわざ
ご指摘ありがとうございます。

コードを書いて頂いたのに自分では難しくて
なかなか内容が把握出来ず動かせない状態です。

もし、ご迷惑でなければ内容を教えて頂けないでしょうか。

お礼日時：2018/01/29 20:22