EXCEL VBA セルの値を連続的に検索・複数セルを抽出・全ての検索・次の検索・同じ検索条件で検索（FindNextメゾット）
EXCEL VBA セルの値を連続的に検索・複数セルを抽出・全ての検索・次の検索・同じ検索条件で検索（FindNextメゾット）
今回説明するのは、ワークシート上のデータを同じ条件にて連続的に検索するFindNextメゾットの利用方法を説明致します。以前にも少しFindNextメゾットの利用方法を説明いたしましたが、Findメゾット中心の説明になっているので、今回は、FindNextメゾットを中心とした説明を行いたいと思います。。ワークシート上のデータの中から同じ条件（文字列）を検索する事が業務上あると思いますが、この時にFindNextメゾットを利用する事で該当するデータを連続的に抽出する事が出来ます。それでは、サンプルプログラムを交えて順番に説明いたします。
●【EXCEL VBA セルの検索（完全一致・部分一致・複数一致）】の使い方、下記を参照して下さい。
●【Range.FindNext メソッド (Excel)、下記を参照して下さい】（Microsoft社 様）】
https://docs.microsoft.com/ja-jp/office/vba/api/excel.range.findnext
● まずは、FindメゾットとFindNextメゾットとの違い。
① Findメゾットの場合・・・下記、図を参考に検索範囲を支店名（列）として、検索値を「神戸支店」とし初回の1回のみ検索します。
② FindNextメゾットの場合・・・FindNextメゾットの場合は、Find＋FindNextメゾットと組み合わせて利用します。下記、図を参考に検索範囲を支店名（列）として、検索値を「神戸支店」とします。1回目の検索は、Findメゾットで検索します。2回目以降については、Findメゾットの検索値を引き継いでFindNextメゾットで次を検索します。下図の様に3件「神戸支店」が有る場合は、１回目は、Findメゾット・2回目以降は、FindNextメゾットで検索します。注意としてFindNextメゾットは、指定範囲内を繰り返して検索しますので、永遠に検索してしまいます。4回目の検索では、1回目の検索と同じなので、1回目（初回）のセル位置などを把握して、検索を終了させる仕組みを作る必要があります。
● FindNextメゾットを利用するには、下記の通りに設定を行います。（サンプル）
【サンプルプログラム】
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
' ' 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メゾット）
下記のサンプルプログラムは、FindNextメゾットを使って該当する文字列が登録されているセル番号・行番号・列番号を取得するサンプルプログラムです。他のプロクラムと組み合わせて利用する時に活用できると思います。詳しくは、サンプルプログラムを交えて順番に説明致します。
【プログラムの流れ】
① セル「Ａ１」を起点にデータ範囲を取得します。
② データ範囲より、検索値【評価：C】（G2）の設定（Findメゾットで1回目の検索）
③ データ範囲に該当する検索値があるか？ 有る場合は…④ 無い場合は…⑪
④ データ範囲に該当する検索値が有る場合は、最初に見つかったセル番号を把握します。
⑤ 検索結果に該当するセル番号等を表示する初期行番号を設定します。（2行目から）
⑥ 検索結果に該当するセル番号をH列に記入します。
⑦ 検索結果に該当する行番号をI列に記入します。
⑧ 検索結果に該当する列番号をJ列に記入します。
⑨ 次の検索を行います（FindNextメゾットで2回目以降）
⑩ 検索結果のセル番号が最初に見つかったセル番号と同じになるまで繰り返します。（同じセル番号が一致した場合は、検索が一巡したことになります。）
⑪ 検索するデータ範囲内に検索値が無い場合は、メッセージボックスに「該当なし」と表示して終了
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
' ' 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メゾット）
下記のサンプルプログラムでは、InputBoxで入力した文字列に該当するデータを抽出するサンプルプログラムです。検索するデータを何度も繰り返し変更して、検索する際にはとでも便利だと思います。それでは、サンプルプログラムを交えて順番に説明いたします。
【プログラムの流れ】
① セル「Ａ１」を起点にデータ範囲を設定します。
② 現在表示されている検索結果の転記先データの最終行を取得します。
③ 検索結果を転記するＨ列（名前）Ｉ列（科目）の既存データをクリアします。クリア範囲は②で取得した最終行＋１をクリア）
④ 検索する評価（数値）を入力します（InputBox) ※入力する数値は、１～５
⑤ 入力した評価（数値）を①で取得したデータ範囲内を検索します。（Findメゾット：１回目）
⑥ データ範囲内に該当する検索結果（評価）があるか？
⑦ 検索結果（ある）１回目の検索結果の該当するセル番号を取得します。：検索結果（ない）メッセージボックスにて「該当なし」を表示してプログラム終了。
⑧ 検索結果の内容を転記する転記先の行を設定します。（２行目から）
⑨ 検索結果で該当する名前をＨ列に転記します。
⑩ 検索結果で該当する科目をＩ列に転記します。
⑪ 入力した評価（数値）を①で取得したデータ範囲内を検索します。（FindNextメゾット：２回目以降）
⑫ 検索結果が１回目と同じセル番号と一致するまで繰り返します。（※全てを検索するため）
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 |
' ' 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メゾット）
下記のサンプルプログラムは、データ範囲より複数の条件で検索を行い、一致した条件毎に別シートにデータを転記するサンプルプログラムです。複数の条件でデータを振り分けるなどの処理を行う時に便利だと思います。それでは、サンプルプログラムを交えて順番に説明いたします。
【プログラムの流れ】
① ワークシート「ＤＡＴＡ」セル「A1」を起点にデータ範囲を取得します。（検索範囲を取得）
② ワークシート「ＤＡＴＡ」セル「H1」を起点に登録されている検索データを取得します。（検索条件を複数取得）
③ 確認・警告メッセージを表示しないように設定します。（非表示設定）
※ワークシートを削除する際に、メッセージが表示されてプログラムが中断されないため）
④ ブック内のワークシート全てを検索します。
⑤ ブック内のワークシート名に「@：アットマーク」があるか確認し、ある場合はそのワークシート名を削除します。
※前回の検索結果のワークシートを削除するため（検索結果で作成したワークシート名に「＠」が登録されています）
⑥ ③で確認・警告メッセージを表示設定に戻します。（表示設定）
⑦ 複数の検索値を順番に繰り返します。ワークシート（DATA）セル「H1」に登録されている検索データ
⑧ 最初の検索を行います（Findメゾットで検索：１回目の検索）
⑨ 該当する検索結果があるか判定します。ある場合⑩へ ない場合は、プログラム終了
⑩ １回目の検索で該当したセル番号を把握します。
⑪ 検索値ごとにワークシートに分けるため新しくワークシートを作成します。
⑫ 新しく作成したワークシート名を「＠」＋検索値にワークシート名を変更します。
⑬ 新しく作成したワークシートの転記先の行を指定します（１行目から）
⑭ 検索値に一致したデータを転記します。（ワークシート「DATA」⇒「新しく作成したワークシート」A列～F列を転記
⑮ 新しく作成したワークシート名に転記する行位置を＋１加算します。
⑯ 次の検索を行います。（FindNextメゾットで検索：２回目の検索）
⑰ 次の検索⑯で該当がなければ、ループから抜けます。
⑱ 次の検索⑯で最初のセル番号⑩を一致するまで繰り返します。⑭へ
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 |
' ' 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 ' ’ |
（画面クリックして拡大）
また、VBAに関するテクニックや便利な手法などをこのサイトに掲載していきますので、定期的に参照していただけると幸いです。