【EXCEL VBA（マクロ）】縦（行）ループして条件に一致するデータを別シートへ転記する

特定の文字を含むデータを行ごとコピーして転記

これは、Excelワークブック内のデータを検索し、特定のキーワードを含む行のデータを別のシートにコピーするエクセルマクロです。

Sub 特定の文字を含むデータを行ごとコピーして転記()

Dim wh1 As Worksheet
Dim wh2 As Worksheet
Dim LastRow As Long
Dim i As Long
Dim J As Long
Dim SearchWord As String

    Set wh1 = ActiveSheet
    Set wh2 = ActiveSheet.Next

    '検索キーワード
    SearchWord = "東京"

    wh1.Select
    J = 2

    '最終行取得
    LastRow = wh1.Cells(Rows.Count, 1).End(xlUp).Row

    For i = 2 To LastRow

        '特定キーワードを含む場合
        If InStr(Cells(i, 1), SearchWord) > 0 Then

             '該当データを転記
             wh1.Range(Cells(i, 1), Cells(i, 3)).Copy wh2.Cells(J, 1)
             J = J + 1
        End If
    Next i
    
MsgBox "完了"
End Sub

解説

まず、2つのワークシートを変数wh1およびwh2にセットします。wh1は現在アクティブなシート、wh2はその次のシートです。
次に、検索するキーワードを変数SearchWordに設定します。この例では、「東京」という文字列が検索対象となります。
その後、変数LastRowに、検索対象となる列（列A）の最終行を設定します。
Forループで、2行目から最終行までの各行について、InStr関数を使って特定のキーワードが含まれているかどうかをチェックします。InStr関数は、指定された文字列内で指定された文字列を検索し、最初に見つかった場所の位置を返します。もし特定のキーワードが含まれている場合は、その行を別のシートにコピーします。
- セルの値が、指定されたキーワード（SearchWord）を含むかどうかを確認します。InStr関数は、検索対象の文字列の中に指定された文字列がある場合には、その位置を返します。この場合、セルの値にSearchWordが含まれる場合には、InStr関数の戻り値が0よりも大きくなります。
最後に、「完了」というメッセージボックスが表示されます。

＊このコードを実行すると、指定されたキーワードが含まれる行が新しいシートにコピーされ、元のシートは変更されません。

条件に合うデータを別シートへ転記

Sub 条件に合うデータを別シートへ転記()

Dim Moto_wsh As Worksheet
Dim DicName As Variant
Dim GetName As String
Dim myKey As Variant
Dim LastRow As Long
Dim i As Long
Dim j As Long
Dim Q As Long

    '連想配列
    Set DicName = CreateObject("Scripting.Dictionary")

    '最終行
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row

    Set Moto_wsh = Sheets("基ﾃﾞｰﾀ")

    '重複しないリストを連想配列へ
    For i = 2 To LastRow
        GetName = Cells(i, 1)

        If Not DicName.Exists(GetName) Then
            DicName.Add GetName, GetName
        End If
    Next i

    '連想配列をループ
    myKey = DicName.keys
    For i = 0 To UBound(DicName.items)

        Q = 2

        '新規シート作成し、1行目のみ転記
        Sheets.Add After:=ActiveSheet
        ActiveSheet.Name = myKey(i)
        ActiveSheet.Range("A1:C1").Value = Moto_wsh.Range("A1:C1").Value

        Moto_wsh.Select

        '「基ﾃﾞｰﾀ」シート セルA2から最終行までループ
        For j = 2 To LastRow

            '連想配列とセル値が一致している場合
            If Moto_wsh.Cells(j, 1) = myKey(i) Then

                 '「基ﾃﾞｰﾀ」シートの値を転記
                 Moto_wsh.Range(Cells(j, 1), Cells(j, 3)).Copy Sheets(myKey(i)).Cells(Q, 1)
                 Q = Q + 1

            End If
        Next j
    Next i

    Set DicName = Nothing
MsgBox "完了"
End Sub

解説

以下が、このエクセルマクロの詳しい解説です：
Sub 条件に合うデータを別シートへ転記()：このマクロは、条件に合うデータを別シートに転記するためのものです。
Dim Moto_wsh As Worksheet：変数Moto_wshを定義し、この変数は「基ﾃﾞｰﾀ」という名前のワークシートオブジェクトを参照します。
Dim DicName As Variant：変数DicNameを定義し、この変数は連想配列オブジェクトを参照します。
Dim GetName As String：変数GetNameを定義し、この変数は文字列を格納します。
Dim myKey As Variant：変数myKeyを定義し、この変数は配列を参照します。
Dim LastRow As Long：変数LastRowを定義し、この変数は整数型の最終行番号を参照します。
Dim i As Long, Dim j As Long, Dim Q As Long：変数i、j、Qを定義し、それぞれループカウンターとして使用します。
Set DicName = CreateObject(“Scripting.Dictionary”)：連想配列オブジェクトを作成し、DicName変数に格納します。
LastRow = Cells(Rows.Count, 1).End(xlUp).Row：最終行を取得し、LastRow変数に格納します。
Set Moto_wsh = Sheets(“基ﾃﾞｰﾀ”)：ワークシートオブジェクト「基ﾃﾞｰﾀ」をMoto_wsh変数に格納します。
For i = 2 To LastRow：2行目から最終行までループし、以下を実行します。
GetName = Cells(i, 1)：変数GetNameに、i行目の1列目の値を格納します。
If Not DicName.Exists(GetName) Then：もしDicNameの中に、GetNameというキーが存在しなければ、以下を実行します。
DicName.Add GetName, GetName：連想配列DicNameに、GetNameをキーとして、GetNameを追加します。
myKey = DicName.keys：連想配列DicNameの全てのキーを、配列myKeyに格納します。
For i = 0 To UBound(DicName.items)：連想配列DicNameの要素数分だけループし、以下を実行します。
Sheets.Add After:=ActiveSheet：新しいワークシートを作成します。
ActiveSheet.Name = myKey(i)：新しいワークシートの名前を、myKey(i)に設定します。
ActiveSheet.Range(“A1:C1”).Value = Moto_wsh.Range(“A1:C1”).Value：
「Set DicName = CreateObject(“Scripting.Dictionary”)」は、Scripting.Dictionary オブジェクトを作成しています。Scripting.Dictionary は、キーと値のペアを格納し、キーを使用して値にアクセスすることができる連想配列です。
「LastRow = Cells(Rows.Count, 1).End(xlUp).Row」は、ワークシート上のデータが入力されている最終行を取得しています。この場合、最終行は1列目の最終行となります。
「Set Moto_wsh = Sheets(“基ﾃﾞｰﾀ”)」は、ワークシート「基ﾃﾞｰﾀ」を取得しています。このワークシートは、元のデータが入力されているワークシートです。
「For i = 2 To LastRow」は、ワークシートの1列目から最終行までの各行をループしています。
「GetName = Cells(i, 1)」は、i 行目の1列目の値を変数 GetName に代入しています。
「If Not DicName.Exists(GetName) Then DicName.Add GetName, GetName」は、DicName 連想配列に、まだ存在しない GetName をキーとして追加しています。
「myKey = DicName.keys For i = 0 To UBound(DicName.items)」は、DicName 連想配列のキーを myKey 配列に代入し、ループを開始しています。
「Sheets.Add After:=ActiveSheet」は、新しいワークシートを作成しています。
「ActiveSheet.Name = myKey(i)」は、新しいワークシートの名前を myKey 配列の i 番目の値に設定しています。
「ActiveSheet.Range(“A1:C1”).Value = Moto_wsh.Range(“A1:C1”).Value」は、ワークシート「基ﾃﾞｰﾀ」の1行目を新しいワークシートの1行目に転記しています。
「For j = 2 To LastRow」は、ワークシート「基ﾃﾞｰﾀ」の2行目から最終行までの各行をループしています。
「If Moto_wsh.Cells(j, 1) = myKey(i) Then」は、ワークシート「基ﾃﾞｰﾀ」の j 行目の1列目の値が、myKey 配列の i 番目の値と一致している場合に、以下の処理を実行します。
「Moto_wsh.Range(Cells(j, 1), Cells(j, 3)).Copy Sheets(myKey(i)).Cells(Q, 1)」は、ワークシート「基ﾃﾞｰﾀ」という名前のワークシートオブジェクトを作成しています。
For i = 2 To LastRow で、最終行までループしています。ループ内の処理では、GetName = Cells(i, 1) で、i 行 1 列目の値を取得しています。
If Not DicName.Exists(GetName) Then で、DicName に GetName が含まれていない場合、GetName をキーとして、DicName に GetName を追加しています。
myKey = DicName.keys で、DicName のキーを配列 myKey に格納しています。
For i = 0 To UBound(DicName.items) で、myKey 配列の各要素に対して、以下の処理を実行しています。
Sheets.Add After:=ActiveSheet で、新規のワークシートを作成しています。作成されたワークシートは、アクティブなワークシートの後ろに配置されます。
ActiveSheet.Name = myKey(i) で、新規ワークシートの名前を、myKey(i) の値に設定しています。
ActiveSheet.Range("A1:C1").Value = Moto_wsh.Range("A1:C1").Value で、新規ワークシートの A1:C1 に、「基ﾃﾞｰﾀ」ワークシートの A1:C1 の値をコピーしています。
Moto_wsh.Select で、「基ﾃﾞｰﾀ」ワークシートをアクティブなワークシートにします。
For j = 2 To LastRow で、「基ﾃﾞｰﾀ」ワークシートのセル A2 から最終行までループしています。
If Moto_wsh.Cells(j, 1) = myKey(i) Then で、Moto_wsh の j 行 1 列目の値が myKey(i) と等しい場合、以下の処理を実行しています。
Moto_wsh.Range(Cells(j, 1), Cells(j, 3)).Copy Sheets(myKey(i)).Cells(Q, 1) で、「基ﾃﾞｰﾀ」ワークシートの j 行 1 列目から 3 列目までの値を、新規ワークシートの Q 行目の 1 列目から 3 列目にコピーしています。Q は新規ワークシートの書き込み開始行番号を表しています。
Q = Q + 1 で、次に書き込む行番号を 1 増やしています。