【VBA】全シートの特定位置を文字列検索して該当シートを抽出するマクロ

大学でMicrosoftOfficeが無料で使えていたのですが、それのライセンスが切れそうなのでこれまで使ったマクロをシェアします。

概要

MicrosoftExcelのVisualBasicで使用可能なマクロのコードです。

指定した位置（セルor列）に検索キーワードが含まれているシートの数を返してくれます。

挙動

①マクロを実行。
②検索したい文字列と検索したい位置を入力。
③ブック内の全シートから②の条件に当てはまるシート数を返してくれる。
④2つ目のキーワードでAND検索するか、1つ目のキーワードをやり直すか聞かれる。
→最大3キーワードまでAND検索可能
→検索を終了した場合は該当シートのみを新規ブックとして複製することが可能

列で検索したいとき、例えばA列を検索したいときは「A:A」と入力してください。

想定される使い道

顧客情報をエクセルで管理しており、各顧客ごとにシートを作成しているとします。

「このセルにはこの属性情報を入れる」というのが全シートで統一されていれば、こちらのマクロで数を調べることができます。

例えば「男性」で検索すればブック内で男性顧客のシート数を返してくれます。

コード

Sub keywordsearch ()
    Dim Flg As Boolean
    Dim Sh As Worksheet
    Dim r As Range
    Dim r_2 As Range
    Dim r_3 As Range
    Dim rc As VbMsgBoxResult
    Dim rc_2 As VbMsgBoxResult

#Sheet(1)には一番左のシート名を入力して一応リセットしてください。
Sheets(1).Select
        Flg = True
        FindStr = ""
        FindStr = Application.InputBox("検索する文字列を入力してください。")
        If Len(FindStr) = 0 Then Exit Sub
        FindRng = ""
        FindRng = Application.InputBox("検索する範囲を入力してください。")
        If Len(FindRng) = 0 Then Exit Sub
        
　　#LookAtがxlPartの場合は部分検索
       #LookAtがxlWholeの場合は全体一致検索
        For Each Sh In ThisWorkbook.Worksheets
         Set r = Sh.Range(FindRng).Cells.Find(What:=FindStr, LookAt:=xlPart)
         If Not r Is Nothing Then
         Sh.Select Replace:=Flg
         Flg = False
         End If
        Next Sh
        
        MsgBox "該当するシート数は" & ActiveWindow.SelectedSheets.Count
        If Flg Then MsgBox "対象のシートはありません"
    
    
    rc_1 = MsgBox("2つ目のキーワードで絞り込みますか?", vbYesNo + vbQuestion)
        If rc_1 = vbYes Then
          MsgBox "2つのキーワードで検索します", vbCritical
           Do
           Sheets(1).Select
           Flg = True
           FindStr_2 = ""
           FindStr_2 = Application.InputBox("2つ目の文字列を入力してください。")
           If Len(FindStr_2) = 0 Then Exit Sub
           FindRng_2 = ""
           FindRng_2 = Application.InputBox("2つ目の検索範囲を入力してください。")
           If Len(FindRng_2) = 0 Then Exit Sub
           
           For Each Sh In ThisWorkbook.Worksheets
           Set r = Sh.Range(FindRng).Cells.Find(What:=FindStr, LookAt:=xlPart)
           Set r_2 = Sh.Range(FindRng_2).Cells.Find(What:=FindStr_2, LookAt:=xlPart)
           If Not r Is Nothing And Not r_2 Is Nothing Then
           Sh.Select Replace:=Flg
           Flg = False
           End If
           Next Sh
           
           MsgBox "該当するシート数は" & ActiveWindow.SelectedSheets.Count
           If Flg Then MsgBox "対象のシートはありません"
           
           rc_4 = MsgBox("2つ目のキーワードをやり直しますか？", vbYesNo + vbQuestion)
           If rc_4 = vbNo Then
           MsgBox "終了します", vbCritical
           Exit Do
           End If
      Loop
      End If
      
      
        rc_2 = MsgBox("3つ目のキーワードで絞り込みますか?", vbYesNo + vbQuestion)
        If rc_2 = vbYes Then
         MsgBox "3つのキーワードで検索します", vbCritical
         Do
         Sheets(1).Select
        Flg = True
        FindStr_3 = ""
        FindStr_3 = Application.InputBox("3つ目の文字列を入力してください。")
        If Len(FindStr_3) = 0 Then Exit Sub
        FindRng_3 = ""
        FindRng_3 = Application.InputBox("3つ目の検索範囲を入力してください。")
        If Len(FindRng_3) = 0 Then Exit Sub
        For Each Sh In ThisWorkbook.Worksheets
        Set r = Sh.Range(FindRng).Cells.Find(What:=FindStr, LookAt:=xlPart)
        Set r_2 = Sh.Range(FindRng_2).Cells.Find(What:=FindStr_2, LookAt:=xlPart)
        Set r_3 = Sh.Range(FindRng_3).Cells.Find(What:=FindStr_3, LookAt:=xlPart)
        If Not r Is Nothing And _
           Not r_2 Is Nothing And _
           Not r_3 Is Nothing Then
            Sh.Select Replace:=Flg
            Flg = False
            End If
        Set r = Nothing
        Set r_2 = Nothing
        Set r_3 = Nothing
        Next Sh
        MsgBox "該当するシート数は" & ActiveWindow.SelectedSheets.Count
        If Flg Then MsgBox "対象のシートはありません"
               rc_5 = MsgBox("2つ目のキーワードをやり直しますか？", vbYesNo + vbQuestion)
        If rc_5 = vbNo Then
          MsgBox "終了します", vbCritical
          Exit Do
        End If
        Loop
        End If
        
 rc_3 = MsgBox("ここまで該当するシートを別にまとめますか？", vbYesNo + vbQuestion)
        If rc_3 = vbYes Then
           ActiveWindow.SelectedSheets.Copy
 thisPath = ThisWorkbook.Path
 ActiveWorkbook.SaveAs _
 Filename:=thisPath & ":" & ThisWorkbook.Name & "_" & FindStr & "_" & FindStr_2 & "_" & FindStr_3 & ".xlsx", _
 FileFormat:=51
         End If
    
End Sub