EXCEL VBA セルの値を連続的に検索・複数セルを抽出・全ての検索・次の検索・同じ検索条件で検索（FindNextメゾット）

EXCEL VBA セルの値を連続的に検索・複数セルを抽出・全ての検索・次の検索・同じ検索条件で検索（FindNextメゾット）

'
'

Sub FindNext00()  'FindNextメゾットの利用方法（サンプル）

    Dim SetRange, srcRange, Firstaddress As String
    
    Set srcRange = Range("A2:A14") 'データ範囲を指定(A2:A14)
    
    srcRange.Interior.ColorIndex = 0 'セル(A2～A14)の背景色をクリアします。
    
    Set SetRange = srcRange.Find(What:=Range("F2"), LookIn:=xlValues) '検索値「神戸支店」（F2）の設定（1回目の検索）

    If Not SetRange Is Nothing Then  'データ範囲に検索結果があるか？
        Firstaddress = SetRange.Address  '該当する結果が有る場合は、1回目の検索結果の該当アドレスを把握します。
        
        Do
            SetRange.Interior.ColorIndex = 6  '検索結果に該当するセルの背景色を黄色に塗りつぶします。
            Set SetRange = srcRange.FindNext(after:=SetRange)  '2回目以降の検索（1回目の検索を引き継ぐ）
        Loop Until SetRange.Address = Firstaddress  '検索結果が1回目のアドレスと一致するまで繰り返します。
    
    Else
        MsgBox "該当なし"  'データ範囲内に該当する検索結果が無ければ、メッセージボックスにて「該当なし」表示して終了。

    End If
    
End Sub

'

EXCEL VBA セルの値を連続的に検索・複数セルを抽出・セル番号・アドレス番号・行番号・列番号（FindNextメゾット）

'
'
Sub FindNext01()  '検索一致したセル番号・行番号・列番号を表示する。

    Dim SetRange, srcRange, Firstaddress As String
    Dim I As Long
    
    Set srcRange = Range("A1").CurrentRegion 'セルA1を元にデータ範囲を指定

    Set SetRange = srcRange.Find(What:=Range("G2"), LookIn:=xlValues)  '検索値【評価：C】（G2）の設定（1回目の検索）

    If Not SetRange Is Nothing Then 'データ範囲に検索結果があるか？
        Firstaddress = SetRange.Address '該当する結果が有る場合は、1回目の検索結果の該当アドレスを把握します。
             
        I = 2  '検索結果の表示する初期行番号（2行目から）
        
        Do
            Cells(I, "H") = SetRange.Address 'H列にセル番号を記入
            Cells(I, "I") = SetRange.Row  'I列に行番号を記入
            Cells(I, "J") = SetRange.Column  'J列に列番号を記入
            Set SetRange = srcRange.FindNext(after:=SetRange) '2回目以降の検索（1回目の検索を引き継ぐ）
            I = I + 1
        
        Loop Until SetRange.Address = Firstaddress '検索結果が1回目のアドレスと一致するまで繰り返します。
    
    Else
        MsgBox "該当なし" 'データ範囲内に該当する検索結果が無ければ、メッセージボックスにて「該当なし」表示して終了。

    End If
    
End Sub
'
'

EXCEL VBA データ範囲からInputBoxで入力して該当するデータを転記します。（FindNextメゾット）

'
'
Sub FindNext02()

    Dim InpRange, SetRange, srcRange, Firstaddress As String
    Dim I, lRow As Long
    Set srcRange = Range("A1").CurrentRegion 'セルA1を元にデータ範囲を指定
   
    
    lRow = Cells(Rows.Count, "H").End(xlUp).Row 'H列の最終行を取得します。
    Range("H2:I" & lRow + 1).ClearContents '検索結果を転記するH列とI列の既存データをクリアします。（登録されている最終行まで）
   
   
    InpRange = InputBox("検索する評価を入力してください(1～5)") '検索する評価の数値を入力します。

    Set SetRange = srcRange.Find(What:=InpRange, LookIn:=xlValues)  'データ範囲から入力した評価数値を検索します。

    If Not SetRange Is Nothing Then  'データ範囲に検索結果があるか？
        Firstaddress = SetRange.Address  'データ範囲に該当する結果が有る場合は、1回目の検索結果の該当アドレスを把握します。
        
        I = 2  '検索結果の転記先の行を指定します。（2行目から）
        
        Do
            Cells(I, "H") = Cells(SetRange.Row, "A")  '該当する名前をH列に転記します。
            Cells(I, "I") = Cells(1, SetRange.Column)  '該当する科目をI列に転記します。
            Set SetRange = srcRange.FindNext(after:=SetRange)  '2回目以降の検索（1回目の検索を引き継ぐ）
            I = I + 1
        
        Loop Until SetRange.Address = Firstaddress   '検索結果が1回目のアドレスと一致するまで繰り返します。
    
    Else
        MsgBox "該当なし"

    End If
    
End Sub
'

EXCEL VBA データ範囲から複数の条件で検索を行い結果を別シート毎に転記（FindNextメゾット）

'
'
Sub FindNext03()  '複数検索一致したデータ別シート毎に転記します。

    Dim ws, ws01 As Worksheet
    Dim SrhRng, SetRng, FindRng, SrhScope As Range
    Dim FirstFind As String
    Dim I As Long
    
    Set ws01 = Worksheets("DATA")
    
    Set SrhScope = ws01.Range("A1").CurrentRegion 'セルA1を起点にデータの範囲を取得します。
    Set SrhRng = ws01.Range("H1").CurrentRegion  'セルH1セルを起点に登録れている検索データを取得します。

    Application.DisplayAlerts = False '確認・警告メッセージを表示しない様に設定する。（非表示設定）

    For Each ws In Worksheets  '全てのワークシートを繰り返します。
        If ws.Name Like "*@*" Then  'ワークシート名に[@:アットマークが有るか確認します。
            ws.Delete  'ワークシート名に「@」があるとワークシートを削除します。
        End If
    Next ws
    
    Application.DisplayAlerts = True '確認・警告メッセージを表示設定に戻す。（表示設定）
  
    For Each SetRng In SrhRng  '複数の検索値を繰り返します。
    
        With SrhScope
            Set FindRng = .Find(SetRng, LookIn:=xlValues, LookAt:=xlPart)  '最初の検索を行う（Findメゾットを使う）
            
            If Not FindRng Is Nothing Then
                FirstFind = FindRng.Address  '1回目の検索で該当したセル番号を記録します。
                
                Set ws = Sheets.Add(After:=Sheets(Sheets.Count)) 'ワークシートを追加します。
                ws.Name = "@" & SetRng  'ワークシート名を変更します。
                I = 1 '追加したワークシートに転記する開始行を指定します。（1行目）
                
                    Do
                        ws.Range("A" & I & ":F" & I).Value = ws01.Range("A" & FindRng.Row & ":F" & FindRng.Row).Value
                                             
                        I = I + 1  '転記先の行を＋１
                        
                        Set FindRng = .FindNext(FindRng)  '次の検索を行う（FindNextメゾトを使う）
                        
                            If FindRng Is Nothing Then Exit Do  '次の検索に該当しなければ、検索ループから抜ける。
                    
                    Loop Until FindRng.Address = FirstFind  '次の検索が初回にセル位置と同じ場合は、ループから抜ける。
            End If
            
        End With
        
    Next SetRng
    
    
End Sub
'
’