[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『エクセルでのGrep検索』(お願いします)
VBA初心者です。
コードを書き換えて下記の機能を持つように改良したいのですが、やり方が分かりません。
下記機能を満たした書き換え後のコードと一緒にコードの解説をして下さると助かります。
・検索結果を検索した文字列ごとにテキストファイルで出力。
→検索結果の出力先ディレクトリを指定できる。
→出力結果テキストファイルの名前はそれぞれシート上で記入した名前になる。
Option Explicit
'-----------------------------------------------------------------
' 関 数 名:初期処理
' 処理概要:初期設定を行う
' 引 数:なし
' 返 却 値:なし
'-----------------------------------------------------------------
Function init()
'カーソル変更 Application.Cursor = xlWait 'ステータスバー Application.StatusBar = "処理中......" '描画抑止 Application.ScreenUpdating = False '自動計算抑止 Application.Calculation = xlCalculationManual End Function
'-----------------------------------------------------------------
' 関 数 名:終期処理
' 処理概要:後始末を行う
' 引 数:なし
' 返 却 値:なし
'--------------------------------------------------------------------------------
Function term()
'自動計算抑止解除 Application.Calculation = xlCalculationAutomatic '描画抑止解除 Application.ScreenUpdating = True 'カーソル変更 Application.Cursor = xlDefault 'ステータスバー Application.StatusBar = False End Function
'--------------------------------------------------------------------------------
' 関 数 名:ハイパーリンク挿入
' 処理概要:ハイパーリンクを設定する
' 引 数:なし
' 返 却 値:なし
'--------------------------------------------------------------------------------
Public Function addHyperLink(ByRef oConfSh As Worksheet)
Dim startRow As Long '検索先頭行 Dim endRow As Long '検索末尾行 Dim col As Long '検索列 Dim idx As Long
startRow = oConfSh.Range(startOutAdd).Row col = oConfSh.Range(startOutAdd).Column endRow = oConfSh.Cells(Rows.Count, "G").End(xlUp).Row
With oConfSh.Hyperlinks For idx = startRow To endRow .Add Anchor:=oConfSh.Cells(idx, "G"), Address:="" Next idx End With With oConfSh.Range(oConfSh.Cells(startRow, "G"), oConfSh.Cells(endRow, "G")) .Font.name = "Meiryo UI" .Font.Size = 10 End With End Function
'★★★★検索文字列リストの先頭アドレス
Const searchListAdd As String = "B10"
'★★★★対象拡張子先頭アドレス
Const extentionListAdd As String = "D10"
'★★★★対象ディレクトリ先頭アドレス
Const dirPathAdd As String = "G10"
'★★★★出力先先頭アドレス
Const startOutAdd As String = "A6"
'--------------------------------------------------------------------------------
' 関 数 名:ハイパーリンク解除
' 処理概要:ハイパーリンクを解除する
' 引 数:なし
' 返 却 値:なし
'--------------------------------------------------------------------------------
Public Function releaseHyperLink(ByRef sh As Worksheet)
Dim startRow As Long '検索先頭行 Dim endRow As Long '検索末尾行 Dim col As Long '検索列
startRow = oConfSh.Range(startOutAdd).Row col = oConfSh.Range(startOutAdd).Column endRow = oConfSh.Cells(Rows.Count, "G").End(xlUp).Row
With sh.Range(sh.Cells(startRow, "G"), sh.Cells(endRow, "G")) .Hyperlinks.Delete .Font.name = "Meiryo UI" .Font.Size = 10 End With End Function
'--------------------------------------------------------------------------------
' 関 数 名:まとめてGrep
' 処理概要:対象ディレクトリ配下にあるファイルから、検索対象文字列リストの文字列を検索する。
' 引 数:なし
' 返 却 値:なし
'--------------------------------------------------------------------------------
Public Sub ListGrep()
Dim searchOption As ClassSearchOptionInfo '検索オプション情報 Dim clsDirInfo() As ClassDirInfo '検索対象情報 Dim iDir As Long '検索ディレクトリ情報カウンタ Dim nowResRow As Long '結果出力行の先頭行
Debug.Print Timer '初期処理 Call init
'画面入力値取得 Set searchOption = getSearchOption() '検索ディレクトリ情報取得 clsDirInfo = getTargetInfo(searchOption.oConfSh)
For iDir = 0 To UBound(clsDirInfo) '出力シートを作成 searchOption.oTmpSh.Copy After:=ThisWorkbook.Worksheets(Worksheets.Count) Set searchOption.oOutSh = ThisWorkbook.Worksheets(Worksheets.Count)
'出力シート名前変更 If clsDirInfo(iDir).outputSheetName <> "" Then searchOption.oOutSh.name = clsDirInfo(iDir).outputSheetName End If '名前の定義 If clsDirInfo(iDir).name <> "" And clsDirInfo(iDir).nameCols <> "" Then searchOption.oOutSh.Range(clsDirInfo(iDir).nameCols).name = clsDirInfo(iDir).name End If '出力位置 nowResRow = searchOption.oOutSh.Range(startOutAdd).Row 'Grep実行 Call doListGrep(clsDirInfo(iDir).topDir, searchOption, nowResRow) Next
'終期処理 Call term Call searchOption.termClassSearchOptionInfo Debug.Print Timer MsgBox "(っ´ω`c)おしまい" End Sub
'--------------------------------------------------------------------------------
' 関 数 名:リストGrep処理
' 処理概要:各ディレクトリ配下のファイルごとにGrepを行う。
' 引 数:ByVal sTopPath As String
' ByVal searchOption As ClassSearchOptionInfo
' ByRef nowResRow As Long
' 返 却 値:なし
'--------------------------------------------------------------------------------
Function doListGrep(ByVal sTopPath As String, ByVal searchOption As ClassSearchOptionInfo, ByRef nowResRow As Long) As String()
'ファイルシステムオブジェクト Dim oFSO As New FileSystemObject '先頭ディレクトリオブジェクト Dim topDir As Folder 'ディレクトリオブジェクト Dim dir As Folder 'ファイルオブジェクト Dim ofile As File
'先頭ディレクトリオブジェクト取得 Set topDir = oFSO.GetFolder(sTopPath)
'ディレクトリ配下のディレクトリパス名を取得する For Each dir In topDir.SubFolders If dir.Attributes <> Alias Then Call doListGrep(dir.path, searchOption, nowResRow) End If Next
'ディレクトリ直下のファイル名を取得する For Each ofile In oFSO.GetFolder(sTopPath).Files '対象拡張子に該当するか確認する If searchOption.isTargetExtention(oFSO.GetExtensionName(ofile.name)) Then '文字列検索処理 Call searchFromFile(ofile, searchOption, nowResRow) '該当した場合は次のファイルを検査 Exit For End If Next End Function
'--------------------------------------------------------------------------------
' 関 数 名:ファイルからの指定文字列検索
' 処理概要:ファイルを1行ずつ読み込み、リストの文字列があるか検索する
' 引 数:ByVal ofile As File
' ByVal searchOption As ClassSearchOptionInfo
' ByRef nowResRow As Long
' 返 却 値:なし
'--------------------------------------------------------------------------------
Function searchFromFile(ByVal ofile As File, ByVal searchOption As ClassSearchOptionInfo, ByRef nowResRow As Long)
Dim oFSO As New FileSystemObject 'ファイルシステムオブジェクト Dim oStream As TextStream 'ストリーム Dim buf, work As String '読み込み領域 Dim regEx As New regExp '正規表現オブジェクト Dim regMc As MatchCollection 'Match Collection Dim iMc As Integer 'マッチング箇所カウンタ Dim regMatch As Match '正規表現matcher Dim idx As Long '検索文字リストカウンタ Dim result(8, 0) As String 'ヒットした情報の格納領域 Dim searchList() As String '検索文字列 Dim srcSeachList() As String '検索文字列ソース
'検索範囲 = 文字列全体を検索 regEx.Global = True '英大文字・小文字の区別 regEx.IgnoreCase = searchOption.isIgnoreCase
searchList = searchOption.getSearchList srcSeachList = searchOption.getSrcSearchList
Set oStream = oFSO.OpenTextFile(ofile.path, ForReading, False) Do While oStream.AtEndOfStream <> True '1行読み込み buf = oStream.ReadLine 'トリムして空行、コメント行(「/*」、「//」、「#」)の場合はスキップ work = Replace(buf, vbTab, "") work = Trim(work) If work = "" Or Left(work, 2) = "/*" Or Left(work, 2) = "//" _ Or Left(work, 1) = "#" Then GoTo Continue End If '検索文字リストとの比較 For idx = 0 To UBound(searchList) regEx.Pattern = searchList(idx) Set regMc = regEx.Execute(buf) 'ヒットした場合 If regMc.Count > 0 Then result(0, 0) = "=N(INDIRECT(""R[-1]C"",FALSE))+1" 'No result(1, 0) = ofile.path 'パス result(2, 0) = ofile.name 'ファイル名 result(3, 0) = oFSO.GetExtensionName(ofile.name) '拡張子 result(4, 0) = FileDateTime(ofile.path) 'タイムスタンプ result(5, 0) = FileLen(ofile.path) 'サイズ result(6, 0) = oStream.line '行 result(7, 0) = srcSeachList(idx) '検索文字 result(8, 0) = buf '検索結果
searchOption.oOutSh.Range(searchOption.oOutSh.Cells(nowResRow, 1), searchOption.oOutSh.Cells(nowResRow, 9)).Value = _ WorksheetFunction.Transpose(result) If searchOption.isHylight = xlOn Then For iMc = 0 To regMc.Count - 1 Set regMatch = regMc.item(iMc) With searchOption.oOutSh.Cells(nowResRow, "I").Characters(Start:=regMatch.FirstIndex + 1, Length:=regMatch.Length).Font '★★★★色を赤にする .Color = RGB(255, 0, 0) End With Next iMc End If nowResRow = nowResRow + 1 End If Next idx Continue: Loop oStream.Close Set oFSO = Nothing End Function
'--------------------------------------------------------------------------------
' 関 数 名:検索文字列リスト取得
' 処理概要:検索文字列を取得する
' 引 数:なし
' 返 却 値:なし
'--------------------------------------------------------------------------------
Function getSearchOption() As ClassSearchOptionInfo
Dim searchOption As New ClassSearchOptionInfo 'まとめてGrepシートオブジェクト Set searchOption.oConfSh = ThisWorkbook.Worksheets("まとめてGrep") '出力シートテンプレート Set searchOption.oTmpSh = ThisWorkbook.Worksheets("まとめてGrep_tmp")
'検索対象文字列 If searchOption.oConfSh.Range(searchListAdd).Value = "" Then MsgBox "検索対象文字列を入力してください。" GoTo Error End If '検索対象文字列 If searchOption.oConfSh.Range(extentionListAdd).Value = "" Then MsgBox "対象拡張子を入力してください。" GoTo Error End If
'英大文字・小文字の区別をする If xlOff = searchOption.oConfSh.CheckBoxes("isIgnoreCase").Value Then searchOption.isIgnoreCase = True Else searchOption.isIgnoreCase = False End If '単語単位で検索するチェックボックス取得 searchOption.isBreak = searchOption.oConfSh.CheckBoxes("isBreak").Value '正規表現チェックボックス取得 searchOption.isRegEx = searchOption.oConfSh.CheckBoxes("isRegEx").Value '結果のハイライト searchOption.isHylight = searchOption.oConfSh.CheckBoxes("isHylight").Value
Call getSearchList(searchOption)
'拡張子リスト Call getExtention(searchOption)
Set getSearchOption = searchOption Exit Function Error: Call term End End Function
'--------------------------------------------------------------------------------
' 関 数 名:検索対象文字列取得
' 処理概要:検索対象文字列を配列に取得する
' 引 数:ByRef searchOption As ClassSearchOptionInfo
' 返 却 値:
'--------------------------------------------------------------------------------
Function getSearchList(ByRef searchOption As ClassSearchOptionInfo)
Dim startRow As Long '検索先頭行 Dim endRow As Long '検索末尾行 Dim col As Long '検索列 Dim iRow As Long '行カウンタ Dim text As String '検索文字列 Dim buf As String '検索文字列 Dim metaChar As Variant Dim searchList() As String Dim srcSearchList() As String Dim idx As Integer Dim item As Variant
metaChar = Array("\", "^", "$", "?", "*", "+", ".", "|", "{", "}", "[", "]", "(", ")") startRow = searchOption.oConfSh.Range(searchListAdd).Row col = searchOption.oConfSh.Range(searchListAdd).Column endRow = searchOption.oConfSh.Cells(Rows.Count, col).End(xlUp).Row
'重複行の削除と書式再設定 Call delDupliData(searchOption.oConfSh, startRow, endRow, col) '末尾行再取得 endRow = searchOption.oConfSh.Cells(Rows.Count, col).End(xlUp).Row
'-------------------------------- '検索対象文字列取得 '-------------------------------- idx = 0 For iRow = startRow To endRow text = searchOption.oConfSh.Cells(iRow, col) buf = searchOption.oConfSh.Cells(iRow, col) '正規表現OFFの場合はメタキャラクタをエスケープ If searchOption.isRegEx <> xlOn Then For Each item In metaChar buf = Replace(buf, item, "\" & item) Next End If '単語単位で検索する場合 If searchOption.isBreak = xlOn Then buf = "\b" & buf & "\b" End If ReDim Preserve searchList(idx) ReDim Preserve srcSearchList(idx) searchList(idx) = buf srcSearchList(idx) = text idx = idx + 1 Next iRow Call searchOption.setSearchList(searchList) Call searchOption.setSrcSearchList(srcSearchList) End Function
'--------------------------------------------------------------------------------
' 関 数 名:検索対象ディレクトリ情報取得
' 処理概要:検索対象ディレクトリ情報を取得する
' 引 数:ByVal oConfSh As Worksheet 設定ワークシート
' 返 却 値:ClassDirInfo
'--------------------------------------------------------------------------------
Function getTargetInfo(ByVal oConfSh As Worksheet) As ClassDirInfo()
Dim startRow As Long '先頭行 Dim endRow As Long '末尾行 Dim col As Long '列
Dim iRow As Long '行カウンタ Dim ext As String Dim buf As Variant '作業領域 ReDim inf(0) As New ClassDirInfo Dim idx As Long
startRow = oConfSh.Range(dirPathAdd).Row col = oConfSh.Range(dirPathAdd).Column endRow = oConfSh.Cells(Rows.Count, col).End(xlUp).Row
idx = 0 For iRow = startRow To endRow ReDim Preserve inf(idx) inf(idx).topDir = oConfSh.Cells(iRow, col) 'パスの存在確認 If "" = dir(inf(idx).topDir, vbDirectory) Then MsgBox iRow & " 行目の対象ディレクトリが存在しません。" GoTo Error End If '出力シート名 inf(idx).outputSheetName = oConfSh.Cells(iRow, col + 1) '名前の定義 inf(idx).name = oConfSh.Cells(iRow, col + 2) '名前を定義する列 inf(idx).nameCols = oConfSh.Cells(iRow, col + 3) idx = idx + 1 Next iRow getTargetInfo = inf Exit Function Error: Call term End End Function
'--------------------------------------------------------------------------------
' 関 数 名:重複データ削除
' 処理概要:重複データを削除する
' 引 数:ByVal oConfSh As Worksheet シート
' ByRef startRow As Long 先頭行
' ByRef endRow As Long 末尾行
' ByRef col As Long 列
' 返 却 値:String() 検索対象拡張子リスト
'--------------------------------------------------------------------------------
Function delDupliData(ByVal oConfSh As Worksheet, ByRef startRow As Long, ByRef endRow As Long, ByRef col As Long)
Dim rng As Range Set rng = oConfSh.Range(oConfSh.Cells(startRow, col), oConfSh.Cells(endRow, col)) With rng .RemoveDuplicates Columns:=1, Header:=xlNo .Borders.LineStyle = True .Font.name = "Meiryo UI" .Font.Size = 10 End With Set rng = Nothing End Function
'--------------------------------------------------------------------------------
' 関 数 名:検索対象拡張子取得
' 処理概要:検索対象拡張子を配列に取得する
' 引 数:ByVal searchOption As ClassSearchOptionInfo
' 返 却 値:
'--------------------------------------------------------------------------------
Function getExtention(ByVal searchOption As ClassSearchOptionInfo)
Dim startRow As Long '検索先頭行 Dim endRow As Long '検索末尾行 Dim col As Long '検索列
Dim iRow As Long '行カウンタ Dim ext As String Dim buf As Variant '作業領域 ReDim extentions(0) As String Dim idx As Long
startRow = searchOption.oConfSh.Range(extentionListAdd).Row col = searchOption.oConfSh.Range(extentionListAdd).Column endRow = searchOption.oConfSh.Cells(Rows.Count, col).End(xlUp).Row
'重複行の削除と書式再設定 Call delDupliData(searchOption.oConfSh, startRow, endRow, col) '末尾行再取得 endRow = searchOption.oConfSh.Cells(Rows.Count, col).End(xlUp).Row
idx = 0 For iRow = startRow To endRow ext = searchOption.oConfSh.Cells(iRow, col) If ext = "*" Then ext = "" Else If InStr(ext, ".") Then ext = Split(ext, ".")(1) End If End If ReDim Preserve extentions(idx) extentions(idx) = ext idx = idx + 1 Next iRow Call searchOption.setExtentionList(extentions) End Function
Option Explicit
'対象ディレクトリ
Public topDir As String
'出力シート名
Public outputSheetName As String
'名前の定義
Public name As String
'名前を定義する列
Public nameCols As String
'設定ワークシートオブジェクト
Public oConfSh As Worksheet
'出力シートテンプレート
Public oTmpSh As Worksheet
'出力シート
Public oOutSh As Worksheet
'検索文字列
Dim searchList() As String
'検索文字列ソース
Dim srcSearchList() As String
'検索対象ファイル(拡張子)
Dim extentionList() As String
'英大文字・小文字を区別する
Public isIgnoreCase As Boolean
'単語単位で検索する
Public isBreak As Integer
'正規表現
Public isRegEx As Integer
'結果のハイライト
Public isHylight As Integer
Public Function setExtentionList(ByRef Target() As String)
extentionList = Target End Function
Public Function setSearchList(ByRef Target() As String)
searchList = Target End Function
Public Function getSearchList()
getSearchList = searchList End Function
Public Function setSrcSearchList(ByRef Target() As String)
srcSearchList = Target End Function
Public Function getSrcSearchList()
getSrcSearchList = srcSearchList End Function
Public Function termClassSearchOptionInfo()
Set oConfSh = Nothing Set oTmpSh = Nothing Set oOutSh = Nothing Erase searchList Erase extentionList End Function
'--------------------------------------------------------------------------------
' 関 数 名:拡張子確認
' 処理概要:対象の拡張子であるか確認する
' 引 数:ByVal sExtention As String 拡張子
' 返 却 値:True 該当
' False 該当しない
'--------------------------------------------------------------------------------
Public Function isTargetExtention(ByVal sExtention As String)
Dim res As Variant 'ワイルドカードの場合True res = Filter(extentionList, "*", True, vbTextCompare) If sExtention <> "" And UBound(res) <> -1 Then isTargetExtention = True Exit Function End If '拡張子がマッチした場合True res = Filter(extentionList, sExtention, True, vbTextCompare) If UBound(res) <> -1 Then isTargetExtention = True Exit Function End If isTargetExtention = False End Function
よろしくお願い致します。
< 使用 Excel:Excel2013、使用 OS:Windows10 >
現状はFilter関数で判定しているかと思いますが、ちゃんとした正規表現を使いたいならば、CreateObject("VBScript.RegExp") について調べてみてください。
(???) 2017/08/03(木) 11:00
もしよろしければ、記述した機能を実装したソースを見本として頂けないでしょうか?
(お願いします) 2017/08/03(木) 11:04
Function fIpCheck(cIP As String) As Boolean With CreateObject("VBScript.RegExp") .Pattern = "^(\d|[1-9]\d|1\d\d|2[0-4]\d|25[0-5])\.(\d|[1-9]\d|1\d\d|2[0-4]\d|25[0-5])\.(\d|[1-9]\d|1\d\d|2[0-4]\d|25[0-5])\.(\d|[1-9]\d|1\d\d|2[0-4]\d|25[0-5])$" fIpCheck = .test(cIP) End With End Function
結果の出力云々は、まずはご自分で頑張ってみてください。
(???) 2017/08/03(木) 11:20
もう一度やれるだけやってみようかと思います
(お願いします) 2017/08/03(木) 11:36
Option Explicit
Type StringPattern
'正規表現のパターン Pattern As String '大文字・小文字を区別するかどうか IgnoreCase As Boolean End Type
Type FilePattern
'検索するフォルダのパス(普通の文字列) FolderPath As String 'ファイル名(正規表現) FileName As String '拡張子(正規表現) Extension As String 'サブフォルダー内も検索するかどうか SubFolders As Boolean '大文字・小文字を区別するかどうか IgnoreCase As Boolean End Type
'RegExpオブジェクト
Private re As Object
Private ref As Object
Private ree As Object
'FileSystemObjectオブジェクト
Private fso As Object
'結果格納用
Private buf As String
'GREP
Function Grep(findString As StringPattern, searchFiles As FilePattern, outFile As String) As Boolean
On Error GoTo OnError Dim ts As Object '文字列検索用RegExpオブジェクト Set re = CreateObject("VBScript.RegExp") With re .Pattern = findString.Pattern .IgnoreCase = findString.IgnoreCase .Global = True End With 'FileSystemObjectオブジェクト Set fso = CreateObject("Scripting.FileSystemObject") '検索するフォルダが存在する場合 If fso.FolderExists(searchFiles.FolderPath) Then 'ファイル名比較用RegExpオブジェクト Set ref = CreateObject("VBScript.RegExp") With ref .Pattern = searchFiles.FileName .IgnoreCase = searchFiles.IgnoreCase .Global = True End With '拡張子比較用RegExpオブジェクト Set ree = CreateObject("VBScript.RegExp") With ree .Pattern = searchFiles.Extension .IgnoreCase = searchFiles.IgnoreCase .Global = True End With 'GREP実行 If Not DoGrep(searchFiles.FolderPath, searchFiles.SubFolders) Then Grep = False Exit Function End If '変数をクリア Set ref = Nothing Set ree = Nothing '出力先フォルダが存在する場合 If fso.FolderExists(fso.GetParentFolderName(outFile)) <> "" Then 'ファイルに出力 Set ts = fso.CreateTextFile(outFile, False) ts.Write buf ts.Close Set ts = Nothing MsgBox "完了しました", vbInformation, "grep" Grep = True '出力先フォルダが存在しない場合 Else MsgBox "フォルダ '" & fso.GetParentFolderName(outFile) & "' が見つかりません", vbExclamation, "Grep" Grep = False End If '検索するフォルダが存在しない場合 Else MsgBox "フォルダ '" & searchFiles.FolderPath & "' が見つかりません", vbExclamation, "Grep" Grep = False End If '変数をクリア buf = "" Set fso = Nothing Set re = Nothing Exit Function OnError: 'エラー発生時 buf = "" Set fso = Nothing Set re = Nothing Set ref = Nothing Set ree = Nothing MsgBox Err.Description, vbCritical, "Grep" Err.Clear Grep = False End Function
'GREP実行
Private Function DoGrep(fpath As String, subfol As Boolean) As Boolean
On Error GoTo OnError Dim pat As String, ext As String Dim ex As Object, m As Object Dim fc As Object, f As Object, ts As Object Dim fn As String, ft As String 'フォルダ内の全ファイル所得 Set fc = fso.GetFolder(fpath).Files For Each f In fc 'ファイル名と拡張子が条件を満たすか判定 pat = fso.GetBaseName(f.Path) ext = fso.GetExtensionName(f.Path) If ref.Test(pat) Then If ree.Test(ext) Then 'ファイルの内容を所得 fn = f.Path Set ts = f.OpenAsTextStream(1) ft = ts.ReadAll ts.Close Set ts = Nothing '検索条件に合致する文字列を格納 Set ex = re.Execute(ft) buf = buf & "[" & fn & "]" & "(" & ex.Count & "件)" & vbCrLf If ex.Count > 0 Then For Each m In ex buf = buf & m.Value & vbCrLf Next End If buf = buf & vbCrLf End If End If Next '変数をクリア Set fc = Nothing 'サブフォルダも検索する場合 If subfol Then Set fc = fso.GetFolder(fpath).SubFolders For Each f In fc 'それぞれのサブフォルダに対してGREP実行 fpath = f.Path If Not DoGrep(fpath, True) Then DoGrep = False Exit Function End If Next '変数をクリア Set fc = Nothing End If DoGrep = True Exit Function OnError: 'エラー発生時 buf = "" Set fc = Nothing Set f = Nothing Set fso = Nothing Set m = Nothing Set re = Nothing Set ref = Nothing Set ree = Nothing MsgBox Err.Description, vbCritical, "Grep" Err.Clear DoGrep = False End Function
(:;:;:;:;:;) 2017/08/03(木) 21:37
Private Sub CommandButon1_Click()
Dim findString As StringPattern Dim searchFiles As FilePattern Dim outFile As String If Range("A1") = "" Or Range("A2") = "" Or Range("A3") = "" Or Range("A4") = "" _ Or Range("A5") = "" Or Range("A6") = "" Or Range("A7") = "" Or Range("A8") = "" Then MsgBox "入力が完了していません", vbExclamation, "Grep" Exit Sub End If With findString .Pattern = Range("A1") .IgnoreCase = Range("A2") End With With searchFiles .FolderPath = Range("A3") .FileName = Range("A4") .Extension = Range("A5") .SubFolders = Range("A6") .IgnoreCase = Range("A7") End With outFile = Range("A8") Grep findString, searchFiles, outFile End Sub (:;:;:;:;:;) 2017/08/04(金) 12:11
Option Explicit
Type StringPattern
'正規表現のパターン Pattern As String '大文字・小文字を区別するかどうか IgnoreCase As Boolean End Type Type FilePattern '検索するフォルダのパス(普通の文字列) FolderPath As String 'ファイル名(正規表現) FileName As String '拡張子(正規表現) Extension As String 'サブフォルダー内も検索するかどうか SubFolders As Boolean '大文字・小文字を区別するかどうか IgnoreCase As Boolean End Type 'RegExpオブジェクト Private re As Object Private ref As Object Private ree As Object 'FileSystemObjectオブジェクト Private fso As Object '結果格納用 Private buf As String Private Sub CommandButon1_Click() Dim findString As StringPattern Dim searchFiles As FilePattern Dim outFile As String If Range("G12") = "" Or Range("G13") = "" Or Range("B2") = "" Or Range("G4") = "" _ Or Range("E7") = "" Or Range("G14") = "" Or Range("G13") = "" Or Range("B3") = "" Then MsgBox "入力が完了していません", vbExclamation, "Grep" Exit Sub End If With findString .Pattern = Range("G12") .IgnoreCase = Range("G13") End With With searchFiles .FolderPath = Range("B2") .FileName = Range("G4") .Extension = Range("E7") .SubFolders = Range("G14") .IgnoreCase = Range("G13") End With outFile = Range("B3") Grep findString, searchFiles, outFile End Sub 'GREP Function Grep(findString As StringPattern, searchFiles As FilePattern, outFile As String) As Boolean On Error GoTo OnError Dim ts As Object '文字列検索用RegExpオブジェクト Set re = CreateObject("VBScript.RegExp") With re .Pattern = findString.Pattern .IgnoreCase = findString.IgnoreCase .Global = True End With 'FileSystemObjectオブジェクト Set fso = CreateObject("Scripting.FileSystemObject") '検索するフォルダが存在する場合 If fso.FolderExists(searchFiles.FolderPath) Then 'ファイル名比較用RegExpオブジェクト Set ref = CreateObject("VBScript.RegExp") With ref .Pattern = searchFiles.FileName .IgnoreCase = searchFiles.IgnoreCase .Global = True End With '拡張子比較用RegExpオブジェクト Set ree = CreateObject("VBScript.RegExp") With ree .Pattern = searchFiles.Extension .IgnoreCase = searchFiles.IgnoreCase .Global = True End With 'GREP実行 If Not DoGrep(searchFiles.FolderPath, searchFiles.SubFolders) Then Grep = False Exit Function End If '変数をクリア Set ref = Nothing Set ree = Nothing '出力先フォルダが存在する場合 If fso.FolderExists(fso.GetParentFolderName(outFile)) <> "" Then 'ファイルに出力 Set ts = fso.CreateTextFile(outFile, False) ts.Write buf ts.Close Set ts = Nothing MsgBox "完了しました", vbInformation, "grep" Grep = True '出力先フォルダが存在しない場合 Else MsgBox "フォルダ '" & fso.GetParentFolderName(outFile) & "' が見つかりません", vbExclamation, "Grep" Grep = False End If '検索するフォルダが存在しない場合 Else MsgBox "フォルダ '" & searchFiles.FolderPath & "' が見つかりません", vbExclamation, "Grep" Grep = False End If '変数をクリア buf = "" Set fso = Nothing Set re = Nothing Exit Function OnError: 'エラー発生時 buf = "" Set fso = Nothing Set re = Nothing Set ref = Nothing Set ree = Nothing MsgBox Err.Description, vbCritical, "Grep" Err.Clear Grep = False End Function 'GREP実行 Private Function DoGrep(fpath As String, subfol As Boolean) As Boolean On Error GoTo OnError Dim pat As String, ext As String Dim ex As Object, m As Object Dim fc As Object, f As Object, ts As Object Dim fn As String, ft As String 'フォルダ内の全ファイル所得 Set fc = fso.GetFolder(fpath).Files For Each f In fc 'ファイル名と拡張子が条件を満たすか判定 pat = fso.GetBaseName(f.path) ext = fso.GetExtensionName(f.path) If ref.Test(pat) Then If ree.Test(ext) Then 'ファイルの内容を所得 fn = f.path Set ts = f.OpenAsTextStream(1) ft = ts.ReadAll ts.Close Set ts = Nothing '検索条件に合致する文字列を格納 Set ex = re.Execute(ft) buf = buf & "[" & fn & "]" & "(" & ex.Count & "件)" & vbCrLf If ex.Count > 0 Then For Each m In ex buf = buf & m.Value & vbCrLf Next End If buf = buf & vbCrLf End If End If Next '変数をクリア Set fc = Nothing 'サブフォルダも検索する場合 If subfol Then Set fc = fso.GetFolder(fpath).SubFolders For Each f In fc 'それぞれのサブフォルダに対してGREP実行 fpath = f.path If Not DoGrep(fpath, True) Then DoGrep = False Exit Function End If Next '変数をクリア Set fc = Nothing End If DoGrep = True Exit Function OnError: 'エラー発生時 buf = "" Set fc = Nothing Set f = Nothing Set fso = Nothing Set m = Nothing Set re = Nothing Set ref = Nothing Set ree = Nothing MsgBox Err.Description, vbCritical, "Grep" Err.Clear DoGrep = False End Function
(お願いします) 2017/08/04(金) 13:52
それでも同じエラーが出る場合は、Err.Clear を消してみてください。エラーはプロシージャが終わるとクリアされるようなので、明示的にクリアしなくてもよいものと思われます。
(:;:;:;:;:;) 2017/08/04(金) 15:40
正規表現の入力が正しくない場合(例えば一文字目で前の文字を必要とする文字('*'や'+'や'?')を使った場合など)に、RegExp オブジェクトの Execute メソッドや Test メソッドが失敗してエラーが発生することがあります(試してみたところ、'アプリケーション定義またはオブジェクト定義のエラーです。'と表示されました)。
(:;:;:;:;:;) 2017/08/04(金) 15:57
・IgnoreCase(大文字・小文字の区別)について
findString.IgnoreCase はファイルの中身を検索するときの設定で、
searchFiles.IgnoreCase は該当するファイルを検索するときの設定です。
それぞれ独立の値を設定することができます。
ちなみに、区別する場合は False 、しない場合は True です。
(:;:;:;:;:;) 2017/08/04(金) 16:10
しかし、書き込みが出来ないとなります。
(お願いします) 2017/08/04(金) 16:39
そして、出来ない時は引数は省略出来ませんとなります。
(お願いします) 2017/08/04(金) 16:45
On Error GoTo OnError をコメントアウトしてみてください。
そうすればエラーが発生するとエラーのダイアログが出て中断されるはずなので、デバッグを選択してエラー箇所を確認してください。
(:;:;:;:;:;) 2017/08/04(金) 17:01
・検索文字列
正規表現。大文字・小文字の区別も指定できる。
・検索するファイル
フォルダ名は普通の文字列として指定。
ファイル名は正規表現(拡張子は含めない)。
拡張子も正規表現(.は含めても含めなくてもよい)。
フォルダ名は大文字・小文字を区別せずに扱われる。
正規表現の部分は、大文字・小文字の区別も指定できる。
・出力ファイル
普通の文字列としてフルパスで指定。
拡張子 .txt は含めても含めなくてもよい。
意図しない入力値によるエラーを防ぐため、セルの値の判定を先にするように書き加えてみました。
Dim findString As StringPattern Dim searchFiles As FilePattern Dim outFile As String If Range("G12") = "" Or Range("G13") = "" Or Range("B2") = "" Or Range("G4") = "" _ Or Range("E7") = "" Or Range("G14") = "" Or Range("G13") = "" Or Range("B3") = "" Then MsgBox "入力が完了していません", vbExclamation, "Grep" Exit Sub End If '書き加えた部分 If InStr(Range("G4"), "\\") > 0 Then MsgBox "ファイル名に不正な文字'\\'があります", vbExclamation, "Grep" Exit Sub End If Range("E7") = Replace(Range("E7"), "\.", "") If Right(Range("B3"), 1) = "\" Then MsgBox "出力ファイルはフルパスで指定してください", vbExclamation, "Grep" Exit Sub End If If Right(Range("B3"), 4) <> ".txt" Then Range("B3") = Range("B3") & ".txt" End If With findString .Pattern = Range("G12") .IgnoreCase = Range("G13") End With With searchFiles .FolderPath = Range("B2") .FileName = Range("G4") .Extension = Range("E7") .SubFolders = Range("G14") .IgnoreCase = Range("G13") End With outFile = Range("B3") Grep findString, searchFiles, outFile End Sub (:;:;:;:;:;) 2017/08/04(金) 18:19
一つ目は、ファイルが空の場合に何もないところから文字列を得ようとするようになっていたことです。これは、ファイルが空でないかの判定を先にすることで、避けられました。
二つ目は、FileSystemObject を使う時に出力できない文字があることです。テキストファイルとして読めないファイルを開いた時などにそこでエラーが発生することがあります。そこで、ADODB.Stream を使ってみたのですが、また別のエラーが発生し、最終的には Excel のファイル操作機能を使うことにしました。
・エラー以外も改良しました。
検索に時間がかかる場合に中断できるようにするため、ループ部分に DoEvents を追加しました。
出力用のファイルとして指定されたファイルが既に存在するとき、処理前にメッセージを表示して終了するようにしました。
以下が書き直したコードです。
Option Explicit
Private Sub CommandButton1_Click()
Dim findString As StringPattern Dim searchFiles As FilePattern Dim outFile As String If Range("G12") = "" Or Range("G13") = "" Or Range("B2") = "" Or Range("G4") = "" _ Or Range("E7") = "" Or Range("G14") = "" Or Range("G13") = "" Or Range("B3") = "" Then MsgBox "入力が完了していません", vbExclamation, "Grep" Exit Sub End If If InStr(Range("G4"), "\\") > 0 Then MsgBox "ファイル名に不正な文字'\\'があります", vbExclamation, "Grep" Exit Sub End If Range("E7") = Replace(Range("E7"), "\.", "") If Right(Range("B3"), 1) = "\" Then MsgBox "出力ファイルはフルパスで指定してください", vbExclamation, "Grep" Exit Sub End If If Right(Range("B3"), 4) <> ".txt" Then Range("B3") = Range("B3") & ".txt" End If With findString .Pattern = Range("G12") .IgnoreCase = Range("G13") End With With searchFiles .FolderPath = Range("B2") .FileName = Range("G4") .Extension = Range("E7") .SubFolders = Range("G14") .IgnoreCase = Range("G13") End With outFile = Range("B3") Call Grep(findString, searchFiles, outFile) End Sub
Option Explicit
Type StringPattern
'正規表現のパターン Pattern As String '大文字・小文字を区別するかどうか IgnoreCase As Boolean End Type Type FilePattern '検索するフォルダのパス(普通の文字列) FolderPath As String 'ファイル名(正規表現) FileName As String '拡張子(正規表現) Extension As String 'サブフォルダー内も検索するかどうか SubFolders As Boolean '大文字・小文字を区別するかどうか IgnoreCase As Boolean End Type 'RegExpオブジェクト Private re As Object Private ref As Object Private ree As Object 'FileSystemObjectオブジェクト Private fso As Object '結果格納用 Private buf As String 'GREP Function Grep(findString As StringPattern, searchFiles As FilePattern, outFile As String) As Boolean On Error GoTo OnError Dim ff As Integer '文字列検索用RegExpオブジェクト Set re = CreateObject("VBScript.RegExp") With re .Pattern = findString.Pattern .IgnoreCase = findString.IgnoreCase .Global = True End With 'FileSystemObjectオブジェクト Set fso = CreateObject("Scripting.FileSystemObject") '検索するフォルダが存在する場合 If fso.FolderExists(searchFiles.FolderPath) Then '出力先フォルダが存在する場合 If fso.FolderExists(fso.GetParentFolderName(outFile)) Then '出力先ファイルが存在しない場合 If Not fso.FileExists(outFile) Then 'ファイル名比較用RegExpオブジェクト Set ref = CreateObject("VBScript.RegExp") With ref .Pattern = searchFiles.FileName .IgnoreCase = searchFiles.IgnoreCase .Global = True End With '拡張子比較用RegExpオブジェクト Set ree = CreateObject("VBScript.RegExp") With ree .Pattern = searchFiles.Extension .IgnoreCase = searchFiles.IgnoreCase .Global = True End With 'GREP実行 If Not DoGrep(searchFiles.FolderPath, searchFiles.SubFolders) Then Grep = False Exit Function End If '変数をクリア Set ref = Nothing Set ree = Nothing 'ファイルに出力 fso.CreateTextFile outFile, False ff = FreeFile Open outFile For Output As #ff Print #ff, buf Close ff MsgBox "完了しました", vbInformation, "Grep" Grep = True '出力先ファイルが存在する場合 Else MsgBox "ファイル '" & outFile & "' は既に存在します", vbExclamation, "Grep" Grep = False End If '出力先フォルダが存在しない場合 Else MsgBox "フォルダ '" & fso.GetParentFolderName(outFile) & "' が見つかりません", vbExclamation, "Grep" Grep = False End If '検索するフォルダが存在しない場合 Else MsgBox "フォルダ '" & searchFiles.FolderPath & "' が見つかりません", vbExclamation, "Grep" Grep = False End If '変数をクリア buf = "" Set fso = Nothing Set re = Nothing Exit Function OnError: 'エラー発生時 buf = "" Set fso = Nothing Set re = Nothing Set ref = Nothing Set ree = Nothing MsgBox Err.Description, vbCritical, "Grep" Err.Clear Grep = False End Function 'GREP実行 Private Function DoGrep(fpath As String, subfol As Boolean) As Boolean On Error GoTo OnError Dim pat As String, ext As String Dim ex As Object, m As Object Dim fc As Object, f As Object, ts As Object Dim fn As String, ft As String 'フォルダ内の全ファイル所得 Set fc = fso.GetFolder(fpath).Files For Each f In fc 'ファイル名と拡張子が条件を満たすか判定 pat = fso.GetBaseName(f.Path) ext = fso.GetExtensionName(f.Path) If ref.test(pat) Then If ree.test(ext) Then 'ファイルの内容を所得 fn = f.Path 'このブック自身を開こうとしたとき・開けないファイルがあったときは '読みとばす If fn = ThisWorkbook.Path Then ft = "" Else Set ts = f.OpenAsTextStream(1) If ts.AtEndOfStream Then ft = "" Else ft = ts.ReadAll End If ts.Close Set ts = Nothing End If '検索条件に合致する文字列を格納 Set ex = re.Execute(ft) buf = buf & "[" & fn & "]" & "(" & ex.Count & "件)" & vbCrLf If ex.Count > 0 Then For Each m In ex buf = buf & m.Value & vbCrLf Next End If buf = buf & vbCrLf End If End If DoEvents Next '変数をクリア Set fc = Nothing 'サブフォルダも検索する場合 If subfol Then Set fc = fso.GetFolder(fpath).SubFolders For Each f In fc 'それぞれのサブフォルダに対してGREP実行 fpath = f.Path If Not DoGrep(fpath, True) Then DoGrep = False Exit Function End If DoEvents Next '変数をクリア Set fc = Nothing End If DoGrep = True Exit Function OnError: 'エラー発生時 buf = "" Set fc = Nothing Set f = Nothing Set fso = Nothing Set ts = Nothing Set m = Nothing Set re = Nothing Set ref = Nothing Set ree = Nothing MsgBox Err.Description, vbCritical, "Grep" Err.Clear DoGrep = False End Function
(:;:;:;:;:;) 2017/08/04(金) 23:33
(お願いします) 2017/08/07(月) 09:09
シートモジュール
Private Sub CommandButton1_Click()
Dim findString As StringPattern Dim searchFiles As FilePattern Dim outFile As String If Range("G12") = "" Or Range("G13") = "" Or Range("B2") = "" Or Range("B4") = "" _ Or Range("E7") = "" Or Range("G14") = "" Or Range("G15") = "" Or Range("B3") = "" Then MsgBox "入力が完了していません", vbExclamation, "Grep" Exit Sub End If If InStr(Range("B4"), "\\") > 0 Then MsgBox "ファイル名に不正な文字'\\'があります", vbExclamation, "Grep" Exit Sub End If Range("E7") = Replace(Range("E7"), "\.", "") If Right(Range("B3"), 1) = "\" Then MsgBox "出力ファイルはフルパスで指定してください", vbExclamation, "Grep" Exit Sub End If If Right(Range("B3"), 4) <> ".txt" Then Range("B3") = Range("B3") & ".txt" End If With findString .Pattern = Range("G12") .IgnoreCase = Range("G13") End With With searchFiles .FolderPath = Range("B2") .FileName = Range("B4") .Extension = Range("E7") .SubFolders = Range("G15") .IgnoreCase = Range("G14") End With outFile = Range("B3") Call Grep(findString, searchFiles, outFile) End Sub
(お願いします) 2017/08/07(月) 09:44
お願いします さんの場合、GetFolderメソッドでフォルダーにアクセスできていないのに、.Filesとファイルを所得しようとしてエラーになっているのかもしれません(あくまで可能性の話ですが)。
可能な場合、一度他のドライブで試してみてはどうでしょうか。
(:;:;:;:;:;) 2017/08/07(月) 11:19
DoGrep関数の
If fn = ThisWorkbook.Path Then は、正しくは If fn = ThisWorkbook.Path & "\" & ThisWorkbook.Name Then です。 (:;:;:;:;:;) 2017/08/07(月) 11:42
先ほどの箇所について
If fn = ThisWorkbook.Path & "\" & ThisWorkbook.Name Or Instr(fn, "~$") > 0 Then です。 (:;:;:;:;:;) 2017/08/07(月) 11:50
Option Explicit
Private Sub CommandButton1_Click()
Dim findString As StringPattern Dim searchFiles As FilePattern Dim outFile As String If Range("G12") = "" Or Range("G13") = "" Or Range("B2") = "" Or Range("G4") = "" _ Or Range("E7") = "" Or Range("G14") = "" Or Range("G13") = "" Or Range("B3") = "" Then MsgBox "入力が完了していません", vbExclamation, "Grep" Exit Sub End If '修正した部分 If Right(Range("B2"), 1) <> "\" Then Range("B2") = Range("B2") & "\" End If If InStr(Range("G4"), "\\") > 0 Then MsgBox "ファイル名に不正な文字'\\'があります", vbExclamation, "Grep" Exit Sub End If Range("E7") = Replace(Range("E7"), "\.", "") If Right(Range("B3"), 1) = "\" Then MsgBox "出力ファイルはフルパスで指定してください", vbExclamation, "Grep" Exit Sub End If If Right(Range("B3"), 4) <> ".txt" Then Range("B3") = Range("B3") & ".txt" End If With findString .Pattern = Range("G12") .IgnoreCase = Range("G13") End With With searchFiles .FolderPath = Range("B2") .FileName = Range("G4") .Extension = Range("E7") .SubFolders = Range("G14") .IgnoreCase = Range("G13") End With outFile = Range("B3") Call GREP(findString, searchFiles, outFile) End Sub
(:;:;:;:;:;) 2017/08/07(月) 16:22
? buf
[C:\Users\ユーザー名\Documents\新しいフォルダー\CSIDEMO.cbl](0件)
[C:\Users\ユーザー名\Documents\新しいフォルダー\LST001.CBL](0件)
(お願いします) 2017/08/07(月) 16:40
ファイルから読み込んだ文字列 ft の値を確認してみてはどうでしょうか。
(:;:;:;:;:;) 2017/08/07(月) 16:48
ボタンクリックで検索をしようとすると「引数は省略できません」となります。
原因はそのあたりの部分っぽいです。
(お願いします) 2017/08/07(月) 17:11
(γ) 2017/08/08(火) 05:00
If ree.test(ext) の処理をするとすぐにEnd Ifに飛んでしまいます。 patとextの両方とも正しく文字列が格納しています。 (お願いします) 2017/08/08(火) 13:58
If ree.test(ext) Then 'ファイルの内容を所得 fn = f.path 'このブック自身を開こうとしたとき・開けないファイルがあったときは '読みとばす If fn = ThisWorkbook.path & "\" & ThisWorkbook.name Or InStr(fn, "~$") > 0 Then ft = "" Else Set ts = f.OpenAsTextStream(1, -1) If ts.AtEndOfStream Then ft = "" Else ft = ts.ReadAll End If ts.Close Set ts = Nothing End If '検索条件に合致する文字列を格納 Set ex = re.Execute(ft) buf = buf & "[" & fn & "]" & "(" & ex.Count & "件)" & vbCrLf If ex.Count > 0 Then For Each m In ex buf = buf & m.Value & vbCrLf Next End If buf = buf & vbCrLf End If ←ここです End If (お願いします) 2017/08/08(火) 14:21
>[C:\Users\ユーザー名\Documents\新しいフォルダー\CSIDEMO.cbl](0件)
>
>[C:\Users\ユーザー名\Documents\新しいフォルダー\LST001.CBL](0件)
>
(:;:;:;:;:;) 2017/08/08(火) 14:35
になっています。
(お願いします) 2017/08/10(木) 09:40
横から失礼。
>ftに格納する文字列のセル位置を指定出来ていないのでしょうか? TextStreamから読み出すだけなので、セル位置とかの意味が不明です。
今までの指摘の解明はどうなっていますか?しっかり確認してみては?
(1) >もしファイルがUnicodeでしたら、OpenAsTextStream(1, -1)としてください これに対するご返事は?
(2) If ree.test(ext) Then で直ぐに抜けていれば、buf変数への文字列セットは行われていないはずなのに、 >[C:\Users\ユーザー名\Documents\新しいフォルダー\CSIDEMO.cbl](0件) のような表示が行われるはずがありませんとの指摘。 これについて、再確認して、事実を示してください。
(3) >念のため、入力するセルの場所です。 大事なのは、あなたがどのような値を書き入れているかです。 場所だけでは情報が不足です。
なお、当方でも正常動作することを確認しました。 (IgnoreCaseの指定が兼用されているのが気にはなりましたが。) あなたがステップ実行して想定通りに動いているかをよく確認することが最善の道です。 もしそれができないなら、回答者側で再現できるような入力を示す必要があります。 # ご自分でデバッグすらできないようなら、VBAでGrepなどといわず、 # 評価の定まって安定動作ししかもユーザーインターフェイスも工夫されている # テキストエディターのGrep機能などを使うべきです。
(γ) 2017/08/11(金) 08:54
開くファイルはshift-JIS形式です。
OpenAsTextStream(1)で正しく開けています。
(2)について
解決出来ました。
ifを想定通りに動いています。
(3)について
・B2 C:\Users\ユーザー名\Documents\新しいフォルダー
・B3 C:\Users\ユーザー名\Documents\新しいフォルダー\tt ・B4 CSIDEMO ・C7〜 WHEN ・E7〜 cbl ・G12 チェック(TRUE) ・G13 チェック(TRUE) ・G14 チェック(TRUE) ・G15 チェック(TRUE)
# のように入力しています。
# 社内用パソコンで新しくソフトを入れることが出来ない環境のため、このようにコードと格闘しつつご質# 問をさせていただいております。
# どうかこの質問にお付き合いいただけると幸いです。
(お願いします) 2017/08/21(月) 09:57
(γ) 2017/08/22(火) 07:17
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.