Office TANAKA - Excel VBA Tips[すべて検索する]

見つかったセルを別のシートにコピーする

すべてのセルを検索する流れは変わりません。

前ページの「見つかったすべてのセルを選択状態にする」では、見つかったセルを次々と変数Targetに格納しましたが、その代わりに、見つかったセルを次々と別のシートにコピーすればいいです。なお、ここでは、Sheet1のデータをSheet2にコピーするものとします。

Sub Sample7()
    Dim FoundCell As Range, FirstCell As Range
    Set FoundCell = Cells.Find(What:="田中")
    If FoundCell Is Nothing Then
        MsgBox "見つかりません"
        Exit Sub
    Else
        Set FirstCell = FoundCell
        別シートにコピーする
    End If
    Do
        Set FoundCell = Cells.FindNext(FoundCell)
        If FoundCell.Address = FirstCell.Address Then
            Exit Do
        Else
            別シートにコピーする
        End If
    Loop
End Sub

これはもう、検索の話ではありませんね。セルのコピーを、どれだけ自在にプログラミングできるかにかかっています。まず、セルのコピーについておさらいしましょう。

下図のように、Sheet1のセル範囲A2:C2を、Sheet2のセルA2にコピーすることを考えます。

最もシンプルに考えれば、次のように書けます。

Sub Sample8()
    Sheets("Sheet1").Range("A2:C2").Copy Sheets("Sheet2").Range("A2")
End Sub

ただし、コピー元である「Range("A2:C2")」は、検索の結果によって変わりますし、コピー先の「Range("A2")」も何件のデータをコピーしたかによって変化します。

Sub Sample8()
    検索で見つかったセル.Copy Sheets("Sheet2").A列の最下行＋1
End Sub

ということです。コピー元の「検索で見つかったセル」は、もう少し正確に言うと

検索で見つかったセルから、同じ行のC列までのセル範囲

ということですね。

こうしたセル範囲を特定するとき、検索で見つかったセルの行番号を調べて「Range("A" & 行番号 & ":C" & 行番号」みたいに下品な方法はいただけません。やるなら「Range(Cells(行番号, 1), Cells(行番号, 3))」または「検索で見つかったセル.Resize(1, 3)」でしょう。ここでは、Resizeでやりましょうか。Resize(1, 3)の「3」を定数や変数に格納しておけば、リストの列が増えたときでも対応が簡単です。また、リストの列数を調べて、動的に変化させることも可能です。

Resizeプロパティというのは「ある大きさのセル範囲を、別の大きさに変更した」結果のセル範囲を返すプロパティです。たとえば、単一のセルというのは「1行×1列」の大きさと表せます。

セル範囲A4:C4は「1行×3列」ですね。

では、単一のセル(ここではセルA6)を「1行×3列」に引き延ばしたらどうでしょう。これは、セル範囲A6:C6と同じことですね。

Resizeプロパティの書式は次の通りです。

元のセル範囲.Resize(新しい行数, 新しい列数)

セルA6を「1行×3列」に変更するには

Range("A6").Resize(1, 3)

となります。

Resizeプロパティの働きを理解したところで、実際の処理を考えてみましょう。
検索で見つかるのは、A列の単一セルです。コピーしたいセル範囲は、その見つかったセルの大きさを「1行×3列」に変更したセル範囲になります。つまり「検索で見つかったセル.Resize(1, 3)」です。

処理の流れは次の通りです。

Sub Sample7()
    Dim FoundCell As Range, FirstCell As Range
    Set FoundCell = Cells.Find(What:="田中")
    If FoundCell Is Nothing Then
        MsgBox "見つかりません"
        Exit Sub
    Else
        Set FirstCell = FoundCell
        別シートにコピーする
    End If
    Do
        Set FoundCell = Cells.FindNext(FoundCell)
        If FoundCell.Address = FirstCell.Address Then
            Exit Do
        Else
            別シートにコピーする
        End If
    Loop
End Sub

とりあえず、コピー元は確定しましたね。

Sub Sample7()
    Dim FoundCell As Range, FirstCell As Range
    Set FoundCell = Cells.Find(What:="田中")
    If FoundCell Is Nothing Then
        MsgBox "見つかりません"
        Exit Sub
    Else
        Set FirstCell = FoundCell
        FoundCell.Resize(1, 3).Copy コピー先
    End If
    Do
        Set FoundCell = Cells.FindNext(FoundCell)
        If FoundCell.Address = FirstCell.Address Then
            Exit Do
        Else
        FoundCell.Resize(1, 3).Copy コピー先
        End If
    Loop
End Sub

では、コピー先はどうしましょう。コピー先は、Sheet2の「最終セルの1つ下のセル」ですね。これを取得する方法は、下記コンテンツで詳しく解説していますので、そちらをご覧ください。

入力されているデータの最終セルを取得する

ということで、次のような感じですね。

Sub Sample7()
    Dim FoundCell As Range, FirstCell As Range
    Set FoundCell = Cells.Find(What:="田中")
    If FoundCell Is Nothing Then
        MsgBox "見つかりません"
        Exit Sub
    Else
        Set FirstCell = FoundCell
        FoundCell.Resize(1, 3).Copy Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    End If
    Do
        Set FoundCell = Cells.FindNext(FoundCell)
        If FoundCell.Address = FirstCell.Address Then
            Exit Do
        Else
            FoundCell.Resize(1, 3).Copy Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
    Loop
End Sub

見つかったセルのアドレスをUserFormで表示する >> 次ページ