複数エクセルファイルから特定の単語を検索するマクロ

大量の仕様書から、今日変更された仕様書だけ知りたい。

横展開するとき、漏れのないように修正したい。

基本的なことですが、悩ましいことです。

次の二つのアプローチで、このような悩みを軽減したいと思います。

1.指定したフォルダ（サブフォルダ含む）にあるファイル、およびその更新日時を一覧化します。

→更新日時でソート書けば、いつどのファイルが変更されたのかはすぐ分かります。

2.特定のキーワードがどのファイルのどこに存在するかを一覧化します。

→横展開の範囲を知るための重要手がかりになります。


次のマクロは
・特定フォルダに格納されているファイルの一覧
・特定キーワードを含むファイルの一覧
を作ってくれます。

インタフェースはこうなります。
1.ファイル一覧


2.特定キーワードを使用するファイルの一覧

ソースコードはこうなります。



'***********************************************
'画面の「検索」ボタンから呼び出される
'***********************************************
Sub SearchWords()

    Dim intLastWordRow As Integer
    Dim intLastFileRow As Integer
    Dim intRow As Integer
 
    Dim strSearchType As String
    Dim strTargetWord As String
    Dim strFileName As String

    Dim objBook As Variant
    Dim objSheet As Variant 'シート
    Dim strAddress As String '開始セルアドレス
    Dim TargetCell As Range '検索目的セル
 
    Dim strWkWord As String
    Dim strWkCell As String
    Dim strWkFile As String
    Dim strWkSheet As String
 
 
    '完全一致・部分一致
    If ThisWorkbook.Sheets("SearchWord").Range("C1").Value = "完全一致" Then
        strSearchType = xlWhole
    Else
        strSearchType = xlPart
    End If
 
 
    'ファイル一覧の最終行
    intLastFileRow = ThisWorkbook.Sheets("FileList").Range("D9").End(xlDown).Row
 
    If ThisWorkbook.Sheets("FileList").Range("D10").Value = "" Then
        MsgBox "先にファイルを検索してください。"
        Exit Sub
    End If

 
    '単語一覧の最終行
    intLastWordRow = ThisWorkbook.Sheets("SearchWord").Range("A10000").End(xlUp).Row

    If intLastWordRow < 2 Then
        MsgBox "単語を指定してください。"
        Exit Sub
    End If


    '画面更新を無効にする
    Application.ScreenUpdating = False
 
    '既存の値をクリアする
    '既存検索結果一覧をクリア
    ThisWorkbook.Sheets("SearchWordResult").Cells.Clear
    ThisWorkbook.Sheets("SearchWordResult").Range("A1").Value = "検索結果"
    ThisWorkbook.Sheets("SearchWordResult").Range("A2").Value = "検索値"
    ThisWorkbook.Sheets("SearchWordResult").Range("B2").Value = "セル値"
    ThisWorkbook.Sheets("SearchWordResult").Range("C2").Value = "ファイル名"
    ThisWorkbook.Sheets("SearchWordResult").Range("D2").Value = "シート名"
    ThisWorkbook.Sheets("SearchWordResult").Range("E2").Value = "セルアドレス"

 
    'ファイル毎の処理
    For i = 10 To intLastFileRow
 
        strFileName = ThisWorkbook.Sheets("FileList").Range("D" & i).Value
     
        'エクセルファイルだけ検索する
        If Right(strFileName, 3) = "xls" Or Right(strFileName, 3) = "xlsx" Then
 
            Set objBook = Application.Workbooks.Open(strFileName)
         
            'シート毎の処理
            For Each objSheet In objBook.Sheets
         
                '単語毎の処理
             
                For j = 2 To intLastWordRow
             
                    strTargetWord = ThisWorkbook.Sheets("SearchWord").Range("A" & j).Value
                 
                    '一回目の検索
                    Set TargetCell = objSheet.Cells.Find(strTargetWord, LookAt:=
                                           _ strSearchType, MatchCase:=False, MatchByte:=False)
             
             
                    If Not TargetCell Is Nothing Then
                         
                        strAddress = TargetCell.Address
                        intRow = ThisWorkbook.Sheets("SearchWordResult").Range("A1").
                                     _ End(xlDown).Row
                         
                        Do
                            '見つかった場合の処理
                         
                            intRow = intRow + 1
                            ThisWorkbook.Sheets("SearchWordResult").Cells(intRow, 1). _
                                 Value = strTargetWord
                            ThisWorkbook.Sheets("SearchWordResult").Cells(intRow, 2). _
                                 Value = TargetCell.Value
                            ThisWorkbook.Sheets("SearchWordResult").Cells(intRow, 3). _
                                 Value = objBook.Name
                            ThisWorkbook.Sheets("SearchWordResult").Cells(intRow, 4). _
                                 Value = objSheet.Name
                            ThisWorkbook.Sheets("SearchWordResult").Cells(intRow, 5). _
                                 Value = TargetCell.Row & "行" & TargetCell.Column & "列"
                                     
                            '二回目以降の検索
                            Set TargetCell = objSheet.Cells.FindNext(TargetCell)
                             
                            '対象単語がないとき、または2回目当たったとき、ループから抜け出す
                            If TargetCell Is Nothing Then Exit Do
                            If TargetCell.Address = strAddress Then Exit Do
                             
                        Loop
                         
                    End If
             
             
             
                Next j
     
           Next objSheet
         
         
           '保存せず終了
            objBook.Close savechanges:=False
     
     
        End If
     

    Next i
 
 
    '画面更新を有効に戻す
    Application.ScreenUpdating = True
    ThisWorkbook.Sheets("SearchWordResult").Activate
 
 
    '検索結果一覧表を作成する
 
     'ヘッダー行の罫線と色
    ThisWorkbook.Sheets("SearchWordResult").Range("A2:E2").Borders.LineStyle = xlContinuous
    ThisWorkbook.Sheets("SearchWordResult").Range("A2:E2").Interior.ColorIndex = 20
 
    '検索値列の昇順でソートをかける
    If ThisWorkbook.Sheets("SearchWordResult").Range("A3") <> "" Then
     
        ThisWorkbook.Sheets("SearchWordResult").Range("A3:E" & intRow).Sort                  
                                           _ key1:=Range("A3:A" & intRow), order1:=xlAscending
 
        '重複値を除去し、罫線をかける
        strWkWord = ThisWorkbook.Sheets("SearchWordResult").Range("A3").Value
        strWkCell = ThisWorkbook.Sheets("SearchWordResult").Range("B3").Value
        strWkFile = ThisWorkbook.Sheets("SearchWordResult").Range("C3").Value
        strWkSheet = ThisWorkbook.Sheets("SearchWordResult").Range("D3").Value
     
        For i = 4 To intRow
     
            '検索値列
            If ThisWorkbook.Sheets("SearchWordResult").Range("A" & i).Value = strWkWord Then
         
                ThisWorkbook.Sheets("SearchWordResult").Range("A" & i).Value = ""
         
            Else
         
                ThisWorkbook.Sheets("SearchWordResult").Range("A" & i - 1).Borders _
                                                                   (xlEdgeBottom).LineStyle = xlContinuous
                strWkWord = ThisWorkbook.Sheets("SearchWordResult").Range("A" & i).Value
         
            End If
         
            'セル値列
            If ThisWorkbook.Sheets("SearchWordResult").Range("B" & i).Value = strWkCell Then
         
                ThisWorkbook.Sheets("SearchWordResult").Range("B" & i).Value = ""
         
            Else
         
                ThisWorkbook.Sheets("SearchWordResult").Range("B" & i - 1).Borders _
                                                                   (xlEdgeBottom).LineStyle = xlContinuous
                strWkCell = ThisWorkbook.Sheets("SearchWordResult").Range("B" & i).Value
         
            End If
         
            'ファイル名
            If ThisWorkbook.Sheets("SearchWordResult").Range("A" & i).Value = "" Then
         
                If ThisWorkbook.Sheets("SearchWordResult").Range("C" & i).Value = strWkFile Then
         
                    ThisWorkbook.Sheets("SearchWordResult").Range("C" & i).Value = ""
             
                Else
         
                    ThisWorkbook.Sheets("SearchWordResult").Range _
                          ("C" & i - 1).Borders(xlEdgeBottom).LineStyle = xlContinuous
                    strWkFile = ThisWorkbook.Sheets("SearchWordResult").Range("C" & i).Value
             
                End If
            Else
         
                ThisWorkbook.Sheets("SearchWordResult").Range("C" & i - 1).Borders _
                                                                    (xlEdgeBottom).LineStyle = xlContinuous
                strWkFile = ThisWorkbook.Sheets("SearchWordResult").Range("C" & i).Value
         
            End If
         
            'シート名
            If ThisWorkbook.Sheets("SearchWordResult").Range("C" & i).Value = "" Then
             
                If ThisWorkbook.Sheets("SearchWordResult").Range("D" & i).Value = _
                    strWkSheet Then
                 
                    ThisWorkbook.Sheets("SearchWordResult").Range("D" & i).Value = ""
             
                Else
                 
                    ThisWorkbook.Sheets("SearchWordResult").Range("D" & i - 1 & ":E" & _
                                                       i - 1).Borders(xlEdgeBottom).LineStyle = xlContinuous
                    strWkSheet = ThisWorkbook.Sheets("SearchWordResult").Range("D" & i).Value
             
                End If
            Else
         
                ThisWorkbook.Sheets("SearchWordResult").Range("D" & i - 1 & ":E" & _
                                                       i - 1).Borders(xlEdgeBottom).LineStyle = xlContinuous
                strWkSheet = ThisWorkbook.Sheets("SearchWordResult").Range("D" & i).Value
         
            End If

        Next i
 

        '列に罫線をかける xlEdgeTop xlEdgeBottom
        ThisWorkbook.Sheets("SearchWordResult").Range("A2:A" & _
                                               intRow).Borders(xlEdgeLeft).LineStyle = xlContinuous
        ThisWorkbook.Sheets("SearchWordResult").Range("A2:A" & _
                                               intRow).Borders(xlEdgeRight).LineStyle = xlContinuous
     
        ThisWorkbook.Sheets("SearchWordResult").Range("C2:C" & _
                                               intRow).Borders(xlEdgeLeft).LineStyle = xlContinuous
        ThisWorkbook.Sheets("SearchWordResult").Range("C2:C" & _
                                               intRow).Borders(xlEdgeRight).LineStyle = xlContinuous
     
        ThisWorkbook.Sheets("SearchWordResult").Range("E2:E" & _
                                               intRow).Borders(xlEdgeLeft).LineStyle = xlContinuous
        ThisWorkbook.Sheets("SearchWordResult").Range("E2:E" & _
                                               intRow).Borders(xlEdgeRight).LineStyle = xlContinuous
     
        ThisWorkbook.Sheets("SearchWordResult").Range("A" & intRow & ":E" & _
                                               intRow).Borders(xlEdgeBottom).LineStyle = xlContinuous
        ThisWorkbook.Sheets("SearchWordResult").Range("A3:E" & intRow). _
                                               VerticalAlignment = xlTop
 
    End If

    ' 処理完了(結果表示)
 
    MsgBox "処理が完了しました。"

End Sub


--------------
以上