[[20170803094726]] 『エクセルでのGrep検索』(お願いします) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『エクセルでのGrep検索』(お願いします)

VBA初心者です。
コードを書き換えて下記の機能を持つように改良したいのですが、やり方が分かりません。
下記機能を満たした書き換え後のコードと一緒にコードの解説をして下さると助かります。


・複数単語の文字列をGrep検索出来る。
  →検索文字は正規表現が設定できる。
  →大文字と小文字の区別が設定できる。
  →検索対象はシート1枚目のセルで指定したディレクトリ。

・検索結果を検索した文字列ごとにテキストファイルで出力。
  →検索結果の出力先ディレクトリを指定できる。
  →出力結果テキストファイルの名前はそれぞれシート上で記入した名前になる。


長くなってしましますが、元のコードです。
標準モジュール

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

Option Explicit

'★★★★検索文字列リストの先頭アドレス
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


Option Explicit

'設定ワークシートオブジェクト
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


んー、検索すれば使用例はいくらでも出てくるように思うのですが…。
折角だから、汎用的に使えそうな例なぞ。 標準モジュールに以下を貼りつけてから、例えばA1セルにIPアドレスっぽい文字列(1.11.111.1、等)を入力。B1セル等は「=fIpCheck(A1)」としてみてください。 そして、0〜255を超える値に変えてみてください。

 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


ご回答ありがとうございます。
調べてみてもGrep検索関連は秀丸やサクラエディタになりがちで、かゆいところに手が届かない状況です。
そのためご質問させていただきました。

もう一度やれるだけやってみようかと思います
(お願いします) 2017/08/03(木) 11:36


ご質問の内容とは少し違いますが、GREPの部分だけ作ってみました。
一応確認はしてみましたが、どこかエラーがあるかもしれません。
検索文字列も検索するファイルも正規表現で指定します。
出力は、テキストファイルを作って、その中に
[ファイル名1](該当件数)
該当文字列1
該当文字列2

[ファイル名2](該当件数)


という風に書き込みます。
正規表現については、RegExpで調べてみてください。

'標準モジュール

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


回答とコードをありがとうございます。
ぜひ動作させてみて、正規表現についても頑張ってみます。
(お願いします) 2017/08/04(金) 09:16

上記のコードは自分で検索文字を受け取るセルの指定やプロシージャーを足さないと動作しませんか?
(お願いします) 2017/08/04(金) 10:45

以下は、コマンドボタンのクリックで実行する例です。
セルの名前は適当に書き換えてください。

'ワークシートモジュール

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

具体例をありがとうございます。
セルの名前を変えて実行してみたところ、On ErrorラベルのErr.Clearでプロシージャーの呼び出しが違っているか引数を誤っているかと表示されます

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


CommandButton1_Click をシートのモジュールに、その他を標準モジュールに分けてください。
シートのモジュール内ではユーザー定義型は Public では定義できません。
シートのモジュールでPrivate Type...End Type と宣言することもできますが、そのモジュール内でしか GREP が使えなくなるのであまりおすすめしません。

それでも同じエラーが出る場合は、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


丁寧な説明をありがとうございます。
シートのモジュールの
Grep findString, searchFiles, outFileを
        ↓
Call Grep(findString, searchFiles, outFile)にしたところ
先程までのエラーはなくなりました。

しかし、書き込みが出来ないとなります。
(お願いします) 2017/08/04(金) 16:39


完了のメッセージは表示されますか?
(:;:;:;:;:;) 2017/08/04(金) 16:43

完了になるときはあるのですが、結果が出力されていません。

そして、出来ない時は引数は省略出来ませんとなります。
(お願いします) 2017/08/04(金) 16:45


私のPC(Windows10, Excel2013)ではうまくいくのですが...。

On Error GoTo OnError をコメントアウトしてみてください。
そうすればエラーが発生するとエラーのダイアログが出て中断されるはずなので、デバッグを選択してエラー箇所を確認してください。
(:;:;:;:;:;) 2017/08/04(金) 17:01


検索結果は出るようになったのですが、該当した文字列の数が言葉を変えても同じ結果が出力されてしまいます。
(お願いします) 2017/08/04(金) 17:49

現時点でのコードはどうなっていますか?
(:;:;:;:;:;) 2017/08/04(金) 18:07

確認のため一応まとめておきます。

・検索文字列
正規表現。大文字・小文字の区別も指定できる。

・検索するファイル
フォルダ名は普通の文字列として指定。
ファイル名は正規表現(拡張子は含めない)。
拡張子も正規表現(.は含めても含めなくてもよい)。
フォルダ名は大文字・小文字を区別せずに扱われる。
正規表現の部分は、大文字・小文字の区別も指定できる。

・出力ファイル
普通の文字列としてフルパスで指定。
拡張子 .txt は含めても含めなくてもよい。

意図しない入力値によるエラーを防ぐため、セルの値の判定を先にするように書き加えてみました。


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")
    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


今までは動作確認はDドライブでしていた(テキストファイル等はほとんどDドライブに入れているため)のですが、Cドライブ>ユーザー>ドキュメントのフォルダーで試してみたところ、「書き込みできません」というエラーが出ました。調べてみると、その原因はCドライブを操作できる権限がないことにあるようです。

お願いします さんの場合、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

修正ありがとうございます。
出力ファイルの作成はされています。しかし検索結果が0件としか表示されません。
仮想ドライブを作成して、そこのディレクトリに対して検索を行っていますが、結果は変わらないようです。
(お願いします) 2017/08/07(月) 12:01

正規表現の文字列に間違いはありませんか?
(:;:;:;:;:;) 2017/08/07(月) 12:15

正規表現を確かめましたが、問題ありませんでした。
完全一致状態での検索でも0件なので、Grepする前段階で引数を受け取り切れていないのかもしれません。
(お願いします) 2017/08/07(月) 13:09

どんな種類のファイルを検索しようとしているのか教えていただけますか?
(:;:;:;:;:;) 2017/08/07(月) 15:31

CBLです。
テキストファイルと同じ要領で出来ると思っているのですが。
(お願いします) 2017/08/07(月) 15:38

メモ帳で開いた時に、正しく文字が表示されますか?
表示されなかったら、テキストファイルのようには扱えないのでまた別の問題になるのですが...。
(:;:;:;:;:;) 2017/08/07(月) 16:02

文字の表示は正しく表示されています。
結果が出力出来ていないだけなのです。
(お願いします) 2017/08/07(月) 16:06

ファイルに出力する前に buf の値を確認してみてください。
(:;:;:;:;:;) 2017/08/07(月) 16:09

フォルダー名の最後に"\"の文字がないとうまくいかないことがあると分かったので、ない場合は付け加えるようにしました。

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はこのようになっています。

? buf
[C:\Users\ユーザー名\Documents\新しいフォルダー\CSIDEMO.cbl](0件)

[C:\Users\ユーザー名\Documents\新しいフォルダー\LST001.CBL](0件)

(お願いします) 2017/08/07(月) 16:40


では、書き込みではなく、読み込みか検索が正しく行われてないということですね。

ファイルから読み込んだ文字列 ft の値を確認してみてはどうでしょうか。
(:;:;:;:;:;) 2017/08/07(月) 16:48


ftの中身を見ようとしてもオブジェクトが必要ですと表示され、見れません。

ボタンクリックで検索をしようとすると「引数は省略できません」となります。

原因はそのあたりの部分っぽいです。
(お願いします) 2017/08/07(月) 17:11


コードを確認していたところ、検索する文字列を格納する変数がないように思ったのですが、いかがでしょうか?
(お願いします) 2017/08/07(月) 17:24

検索する文字列はftに一時的に格納して、検索を行い、結果をbufに書き加えていっています。
ftに文字列を格納するところの条件分岐はすべて Elseで当てはまらない場合の処理も書いています。
(:;:;:;:;:;) 2017/08/07(月) 17:50

もしファイルがUnicodeでしたら、OpenAsTextStream(1, -1)としてください。第2引数を省略するとASCIIファイルとして開かれるようです。
(:;:;:;:;:;) 2017/08/07(月) 17:58

横入り失礼。
冒頭の長いコードは、VBA grepでヒットするサイトの
ものですね。無断借用は、マナーに欠けるでしょう。
(少なくとも出典を明示すべきでしょう。)
しかも丸投げ?
丸投げなら、既成のツールを使うべきでは?
秀丸なら、grep機能はじめ多機能です。
検索結果の一覧(行番号含む)から当該箇所にジャンプできます。
いわゆるタグジャンプ機能。
コード作成のツールなら、一日の長があるはずです。
なお、回答者さんの御苦労を多とする気持ちが
あることも申し添えます。

(γ) 2017/08/08(火) 05:00


借用の点、思慮が足りませんでした。
VBAに関して勉強中のため、構文等をネットで調べられても自分のコードに反映させることが上手くいかず、丸投げのようになっていることも反省しております。
もちろんこの質問に対してご指摘・回答をして下さる方々に深く感謝をしております。
(お願いします) 2017/08/08(火) 09:18

 If ree.test(ext) の処理をするとすぐにEnd Ifに飛んでしまいます。
patとextの両方とも正しく文字列が格納しています。
(お願いします) 2017/08/08(火) 13:58

End If って、どこの End If ですか?
(:;:;:;:;:;) 2017/08/08(火) 14:04

If ref.test(pat) Then
            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

buf がこのようになっているのなら、ループの中を2回通っているはずなのですが...。

>[C:\Users\ユーザー名\Documents\新しいフォルダー\CSIDEMO.cbl](0件)

>[C:\Users\ユーザー名\Documents\新しいフォルダー\LST001.CBL](0件)

(:;:;:;:;:;) 2017/08/08(火) 14:35


ftに格納する文字列のセル位置を指定出来ていないのでしょうか?
(お願いします) 2017/08/08(火) 16:31

念のため、入力するセルの場所です。
・B2 検索対象ディレクトリ
・B3 出力フォルダ名までのパス
・B4 検索ファイル名
・C7〜 検索対象文字列
・E7〜 対象拡張子
・G12 検索対象文字列の正規表現をするかチェックボックス
・G13 検索ファイルの正規表現設定チェックボックス
・G14 該当したファイルの大文字・小文字の区別設定チェックボックス
・G15 サブフォルダを検索するかのチェックボックス

になっています。
(お願いします) 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


(1)について
開くファイルは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/04(金) 23:33
(:;:;:;:;:;) 2017/08/07(月) 16:22
入力に使用するセル位置が「2017/08/21(月) 09:57」の内容と微妙に違うようです。
 
また、検証結果も改めて示してください。
ブレークポイントなどを利用して途中で止めて、
・ファイルの読み込みが適正に実行されていることをどのように確認したか。
・正規表現による文字抽出ができていないことを、どのように確認したか
を説明してください。
(γ) 2017/08/22(火) 07:02

実行してうまくいかない、だけでなく
なぜ思うような結果が得られないのか、
どこが問題なのかという問題意識を持って、
デバッグをしていただきたい。
 
デバッグ手法はこちらを参考にしてくだし。
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_030.html
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_030_02.html
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_030_03.html
 
すべてをステップ実行するわけにいかないので、
適切なところにブレークポイントを複数設けて、
その間をステップ実行するなりして、うまくいかない理由を突き詰めて下さい。

(γ) 2017/08/22(火) 07:17


時間が空いてしまいましたが、報告です。
何とか動作するようになりました。
ここまで長い時間お付き合いして、回答してくださった方々まことに感謝しております。
思うような結果がなぜ得られないのか問題意識をもって取り組むというお言葉が身に沁みました。
(お願いします) 2017/08/28(月) 09:20

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.