ディレクトリ内EXCELファイル内容の一括検索

EXCEL / VBA / ファイル内検索

秀丸のGREPって便利だなーと前から思っていたのですが、今回ヘッダの一括変換とか該当シートの一括削除とかやっていて、どうもEXCELファイル内容の検索も出来そうだと思って作ってみました。

……Setがどういう働きのものなのか分かってなくて(多分基本中の基本)お陰で(多分)ちょーケアレスミスに気付かず昨日は終電帰りでしたが。出来たので本望です。納品前に使おうっと。

本当は検索結果を表示していく部分も変数で設定した方が良かったんでしょうがベタでやっちゃってます。大した修正じゃないんだろうけど今はこれにて。

Private Sub CommandButton2_Click()
    '================================
    ' ディレクトリ内の全ブックをループ
    '================================
    Dim myPath As String
    Dim myFName As String
    Dim myHeader As String
    Dim myOriginalBook As Workbook
    Dim mySelectSheet As Worksheet
    Dim myResultCellNumber As Integer

    Set myOriginalBook = ActiveWorkbook
'    Set myOriginalBook = Workbooks("3.01.003.99変換テスト.xls")
'    myOriginalBook.Activate
   
    myResultCellNumber = 5
   
    ' 検索対象文字列を取得
    myHeader = Worksheets(1).Range("SEARCH_STR").Value
   
    ' パスを取得
    myPath = ActiveWorkbook.Path
    ' 自ファイルが存在しているディレクトリをカレントディレクトリに設定
    ChDir myPath
    myFName = Dir("*.xls")
    ' ファイルがなくなるまで検索
    Do Until myFName = ""
       
        If Not (myOriginalBook.Name = myFName) Then
            ' ファイルOPEN
            Workbooks.Open Filename:=myFName
   
            '================================
            ' 検索
            '================================
            Dim MySheet As Sheets
            Dim SCount As Integer
            Dim myFoundCell As Range
            Dim myFoundCellLoop As Range
   
            Set MySheet = ActiveWorkbook.Sheets
            SCount = MySheet.Count
            ' 全ワークシートをループ
            For mycount = 1 To SCount
                ' mycount件めのシートをアクティブにする
                Set mySelectSheet = Worksheets(mycount)
                mySelectSheet.Activate
               
                Set myFoundCell = mySelectSheet.Cells.Find( _
                                                What:="rcvo", _
                                                After:=Range("A1"), _
                                                LookIn:=xlFormulas, _
                                                LookAt:=xlPart, _
                                                SearchOrder:=xlByRows, _
                                                SearchDirection:=xlNext, _
                                                MatchCase:=False, _
                                                MatchByte:=False, _
                                                SearchFormat:=False)
               
               
                ' 1件めの検索結果が存在した場合
                If Not (myFoundCell Is Nothing) Then
                    myFoundCell.Activate
                   
                    Dim myFirstCell As String
                    myFirstCell = myFoundCell.Address
                   
                    myOriginalBook.Worksheets(1).Range("A" & myResultCellNumber).Value = ActiveWorkbook.Name
                    myOriginalBook.Worksheets(1).Range("B" & myResultCellNumber).Value = mySelectSheet.Name
                    myOriginalBook.Worksheets(1).Range("C" & myResultCellNumber).Value = myFoundCell.Address
                    myOriginalBook.Worksheets(1).Range("D" & myResultCellNumber).Value = myFoundCell.Value
                    myResultCellNumber = myResultCellNumber + 1

                    ' 以降、検索を継続
                    Set myFoundCellLoop = mySelectSheet.Cells.FindNext(After:=myFoundCell)
                    myFoundCellLoop.Activate

                    Do While Not myFirstCell = myFoundCellLoop.Address
                        myOriginalBook.Worksheets(1).Range("A" & myResultCellNumber).Value = ActiveWorkbook.Name
                        myOriginalBook.Worksheets(1).Range("B" & myResultCellNumber).Value = mySelectSheet.Name
                        myOriginalBook.Worksheets(1).Range("C" & myResultCellNumber).Value = myFoundCellLoop.Address
                        myOriginalBook.Worksheets(1).Range("D" & myResultCellNumber).Value = myFoundCellLoop.Value
                        myResultCellNumber = myResultCellNumber + 1

                        Set myFoundCellLoop = mySelectSheet.Cells.FindNext(After:=myFoundCellLoop)
                        myFoundCellLoop.Activate
                    Loop
                End If
               
            Next mycount

            ' ファイルを保存せずCLOSE
            Workbooks(myFName).Close SaveChanges:=False
   
        End If
        ' 次のファイル名を設定
        myFName = Dir()
    Loop
End Sub