VBAで任意のフォルダ内のファイルの特定の文字列を

質問

お世話になります。今、Excelを使用しVBAで任意のフォルダ内に含まれるファイル（txt形式ですが拡張子はありません）から、特定のA～Bの部分の文字列のみを抜き出し、ExcelのSheetに出力させるというVBAを作成しようと考えています。また、A～Bで抽出した文字列内に”空白”が含まれる場合、その空白でセルを隔てるという処理を加えたいです。

また、それらとは別に任意のフォルダ内に含まれるファイルのファイル名のみを抽出し、Excelに出力するというVBAも作ろうと考えています。

私自身、これまでExcelでは関数を使うのが精一杯でVBAの勉強すらしてきませんでしたので、だいぶ困窮しております。

どなたか、VBAについて詳しい方、ご教授いただけたら幸いです。

以下は、参考までに、特定のフォルダ内に含まれるファイルをSheetに出力するVBAになります。
ここからさらに、任意の文字列を検索し、抽出し、出力する機能と、また空白部分でセルを分ける機能、またファイル名一覧を抽出する機能を加えていきたい所存です。

どなたか、お力添えの程何卒よろしくお願い致します。

Sub GetAllFile()
Dim buf As String, tmp As Variant, cnt As Long, i As Long
Dim myFol As String, myFile As String
Dim fNo As Integer, myCol As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "*** 対象フォルダを選択し、[OK]をクリック ***"
.InitialFileName = "C:\"
If .Show = True Then
myFol = .SelectedItems(1)
End If
End With
myFile = Dir(myFol & "\*")
myCol = 0
Do While myFile <> ""
fNo = FreeFile
Open myFol & "\" & myFile For Input As #fNo
Do Until EOF(fNo)
Line Input #fNo, buf
tmp = Split(buf, ",")
cnt = cnt + 1
For i = 1 To UBound(tmp) + 1
Cells(cnt, i + myCol) = tmp(i - 1)
Next i
Loop
Close #fNo
myFile = Dir()
myCol = myCol + 4
cnt = 0
Loop
End Sub

上記、VBAは動作はしましたが、やはりフォルダ内のファイル数の数により、途中でフリーズしてしまう事もありました。ご教授の程、何卒よろしくお願い致します。

回答No.1

cj_mover

こんにちは。
全体の設計について、
解決に必要な情報（条件や要求仕様）を整理した方が宜しいかと。
概算２％の確率で要求に叶っていそうな例を一つだけ。
条件が外れればエラーもあり得ます。
望む結果との違いを見て、少し考えてみてください。

対象ファイルは、カンマ区切りだけれどもCSVテキストではない、という理解です。
”空白”とは半角スペースという理解です。
半角スペースで区切った文字列要素は、単純にひとつずつ右のセルに出力します。
各ファイル単位で列の開始位置を揃えますが、カンマ区切りの列位置はズレる場合あります。
カンマ、半角スペース、タブ文字、改行、引用符、等の役物記号は、各データ要素には含まれないとします。
横方向に連ねて順次出力しますが、列数の不足には陥らない、ものとします。
"A～Bで抽出した文字列"をカンマと改行で区切った文字列から抜き出すのは妙なので、
Aが含まれる行から、次にBが見つかる行までを抜き出します。
A、B、どちらかが見つからない場合は、出力せず、その旨、メッセージ表示します。

' ' ====================== 標準モジュール専用 =======================
Option Explicit

Private Const sKeyA = "A"　　'　　検索キーワードＡ（先頭）◆要指定！
Private Const sKeyB = "B"　　'　　検索キーワードＡ（終端）◆要指定！
Private Const sDelimiter = ","　　'　　メインの区切り文字
Private Const sSubDelimiter = " "　　'　　サブの区切り文字

Sub Re8277749()　　'　　実行プロシージャ
　　Dim objFSO As Object ' As Scripting.FileSystemObject
　　Dim objFiles As Object ' As Scripting.Files
　　Dim oFile As Object ' As Scripting.File
　　Dim objDataObj As Object ' As MSForms.DataObject
　　Dim myFol As String
　　Dim myFile As String
　　Dim buf As String
　　Dim sReport As String
　　Dim cnt As Long
　　Dim myCol As Long
　　Dim flgFound As Boolean

　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　　.Title = "*** 対象フォルダを選択し、[OK]をクリック ***"
　　　　.InitialFileName = "C:\"　　'　　◆要指定！
　　　　.AllowMultiSelect = False
　　　　If .Show = True Then
　　　　　　myFol = .SelectedItems(1)
　　　　Else
　　　　　　MsgBox "キャンセルされました。"
　　　　　　Exit Sub
　　　　End If
　　End With

　　' ' ファイルシステムオブジェクト
　　Set objFSO = CreateObject("Scripting.FileSystemObject")
　　Set objFiles = objFSO.GetFolder(myFol).Files

　　' ' データオブジェクト
　　Set objDataObj = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

　　' ' 出力用シートを追加
　　Worksheets.Add After:=ActiveSheet

　　' ' 指定フォルダのすべてのファイルをループ
　　For Each oFile In objFiles
　　　　myFile = oFile.Name
　　　　' ' ファイル名に拡張子が無いならば
　　　　If objFSO.GetExtensionName(myFile) = "" Then
　　　　　　' ' テキストストリームでファイルを開く
　　　　　　With oFile.OpenAsTextStream
　　　　　　　　' ' すべてをbufに読み込み
　　　　　　　　buf = .ReadAll
　　　　　　　　' ' キーワード検索結果、同時にテキスト抽出、整形
　　　　　　　　flgFound = FormatText(buf)
　　　　　　　　' ' キーワード２つとも見つかっていたならば
　　　　　　　　If flgFound = True Then
　　　　　　　　　　cnt = cnt + 1
　　　　　　　　　　' ' ファイル名リスト
　　　　　　　　　　Cells(cnt, 1) = myFile
　　　　　　　　　　' ' 先頭行にファイル名
　　　　　　　　　　buf = myFile & vbCrLf & buf

　　　　　　　　　　' ' DataObject経由でクリップボードにbufを送信→貼付け
　　　　　　　　　　myCol = ActiveSheet.UsedRange.Columns.Count + 1
　　　　　　　　　　With objDataObj
　　　　　　　　　　　　.SetText buf
　　　　　　　　　　　　.PutInClipboard
　　　　　　　　　　　　Cells(1, myCol).PasteSpecial
　　　　　　　　　　　　.Clear
　　　　　　　　　　End With
　　　　　　　　Else
　　　　　　　　　　sReport = sReport & vbLf & myFile & vbTab & sKeyA & " または " & sKeyA & "　見つかりません"
　　　　　　　　End If
　　　　　　　　.Close
　　　　　　End With
　　　　End If
　　Next

　　Cells(1).Resize(cnt).Select
　　If sReport = "" Then
　　　　sReport = vbTab & "フォルダ名 " & vbLf & myFol & vbLf & vbTab & "抽出結果" _
　　　　　　　　& vbLf & "すべてのファイルがマッチしました。"
　　Else
　　　　sReport = vbTab & "フォルダ名 " & vbLf & myFol & vbLf & vbTab & "抽出結果" _
　　　　　　　　& vbLf & "以下のファイルはマッチしませんでした。" _
　　　　　　　　& vbLf & sReport
　　End If
　　MsgBox sReport, vbInformation, "抽出完了"
End Sub

Private Function FormatText(ByRef sBuf As String) As Boolean
　　Const nLenCrLf As Long = 2&
　　Dim nPosA As Long
　　Dim nPosB As Long
　　Dim nPosARow As Long
　　Dim nPosBRow As Long

　　' ' KeyA検索
　　nPosA = InStr(1, sBuf, sKeyA, vbTextCompare)
　　If nPosA = 0 Then Exit Function　　'　　KeyAが見つからなければ抜ける

　　' ' KeyB検索
　　nPosB = InStr(nPosA, sBuf, sKeyB, vbTextCompare)
　　If nPosA = 0 Then Exit Function　　'　　KeyBが見つからなければ抜ける

　　' ' KeyAが見つかった行の先頭位置を検索
　　nPosARow = InStrRev(sBuf, vbCrLf, nPosA) + nLenCrLf
　　If nPosARow = nLenCrLf Then nPosARow = 1
　　' ' KeyBが見つかった行の終端位置を検索
　　nPosBRow = InStr(nPosB, sBuf, vbCrLf) - 1 + nLenCrLf
　　If nPosBRow < nLenCrLf Then
　　　　sBuf = sBuf & vbCrLf
　　　　nPosBRow = Len(sBuf)
　　End If

　　' ' KeyAが見つかった行の先頭位置からKeyBが見つかった行の終端位置まで抜出
　　sBuf = Mid$(sBuf, nPosARow, nPosBRow - nPosARow + 1)
　　' ' 区切り文字をTABに統一
　　sBuf = Replace(sBuf, sDelimiter, vbTab)
　　sBuf = Replace(sBuf, sSubDelimiter, vbTab)
　　' ' KeyA、KeyB、ともに見つかった、という意味のフラグを返す
　　FormatText = True
End Function