複数のExcelファイルの内容を検索

複数のExcelファイルの内容を検索する方法。

200近いExcelファイルがあって、しかも各ファイル内に10以上のシートがあって
その中に特定の文字列があるかどうかを調べなければいけなくなった。
Excel単独の機能にはそういう検索機能はない。。。。。。。。。

ということで調べたところ、そういう検索専用のソフトがあったけれどマクロでやる方がお手軽。
スウェーデンのOscarさんという人がそういうマクロを作っていたので使わせていただく。
http://www.get-digital-help.com/2014/01/08/search-all-workbooks-in-a-folder/

実行手順は以下。
1.検索したいExcelファイルを全て同一フォルダに置く。
　対象となる拡張子は.xls、.xlsx、.xlsmの3種類。
2.OscarさんのページからExcelファイルをダウンロードしてマクロを実行する。
3.検索するフォルダを聞かれるので1のフォルダを指定する。
4.検索したい文字列を聞かれるので、入力する。
5.あとは待つだけ。検索結果は新しいシートに表示される。

便利

このままでも十分だけど以下のようにちょっぴり修正してから利用させていただきました。

　・マッチしたセルの内容を結果シートに表示する。
　・検索条件を完全マッチではなく部分マッチにする。
　・メッセージを日本語に変更。   
　・画面がチカチカするのがうざいので描画を停止。
　・ダイアログでキャンセルしても処理が続行してたので終了するように修正。

ということで修正後の内容は以下の通り。うん、便利

Sub SearchWKBooks()
Dim WS As Worksheet
Dim myfolder As String
Dim Str As String
Dim a As Single
Dim sht As Worksheet

Set WS = Sheets.Add

With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    myfolder = .SelectedItems(1) & "\"
End With

Str = Application.InputBox(prompt:="検索文字列:", Title:="今指定したフォルダにある全Excelファイルを検索します", Type:=2)

If Str = "False" Then Exit Sub
If Str = "" Then Exit Sub

WS.Range("A1") = "検索文字列:"
WS.Range("B1") = Str
WS.Range("A2") = "パス:"
WS.Range("B2") = myfolder
WS.Range("A3") = "ファイル名"
WS.Range("B3") = "シート名"
WS.Range("C3") = "セル"
WS.Range("D3") = "リンク"
WS.Range("E3") = "セル内の文字列"

a = 0
               
Application.ScreenUpdating = False

Value = Dir(myfolder)
Do Until Value = ""
    If Value = "." Or Value = ".." Then
    Else
        If Right(Value, 3) = "xls" Or Right(Value, 4) = "xlsx" Or Right(Value, 4) = "xlsm" Then
            On Error Resume Next
            Workbooks.Open Filename:=myfolder & Value, Password:="zzzzzzzzzzzz"
            If Err.Number > 0 Then
                WS.Range("A4").Offset(a, 0).Value = Value
                WS.Range("B4").Offset(a, 0).Value = "Password protected"
                a = a + 1
            Else
                On Error GoTo 0
                For Each sht In ActiveWorkbook.Worksheets

'セルの文字列に完全マッチしたいならxlWholeを使う。部分マッチしたいならxlPartを使う。
'                        Set c = sht.Cells.Find(Str, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
                        Set c = sht.Cells.Find(Str, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
                        If Not c Is Nothing Then
                            firstAddress = c.Address
                            Do
                                WS.Range("A4").Offset(a, 0).Value = Value
                                WS.Range("B4").Offset(a, 0).Value = sht.Name
                                WS.Range("C4").Offset(a, 0).Value = c.Address
                                WS.Hyperlinks.Add Anchor:=WS.Range("D4").Offset(a, 0), Address:=myfolder & Value, SubAddress:= _
                                sht.Name & "!" & c.Address, TextToDisplay:="Link"
                                WS.Range("E4").Offset(a, 0).Value = c.Value
                                a = a + 1
                                Set c = sht.Cells.FindNext(c)
                            Loop While Not c Is Nothing And c.Address <> firstAddress
                        End If
                Next sht
            End If
            Workbooks(Value).Close False
            On Error GoTo 0
        End If
    End If
    Value = Dir
Loop

Application.ScreenUpdating = True

Cells.EntireColumn.AutoFit
End Sub