Excel VBA 一覧に一致する行をコピーして出力する方法

どうも、カネスズです。

今回はタイトル通り、「一覧に一致する行をコピーして出力する」マクロをVBAで組んで

見たので紹介したいと思います。

と言っても、私は現在VBAの勉強中なので不具合が出るかもしれませんが、ご了承ください。

※今回はソースと使用例の紹介のみです。ソースの解析はまた別記事で行います。

1 用途
2 ソースコード
- 2.1 注意点１：対象シートは同じブックに置くこと
- 2.2 注意点2：比較値はA列に置くこと
3 実行結果
4 おわりに

用途

このマクロを組もうと思ったきっかけは、仕事で資料の作成を頼まれたのですが

手作業では時間がかかりすぎる！！

そう判断し、マクロ化することにしました。

仕事の内容としては

「この一覧にある値に一致する値があれば、そのデータをコピーして

新しい一覧を作ってちょ」

というものでした。

これだけでは分からないと思うので、図解します。

まずは検索する値です。

次に比較値をもとにして探すデータ一覧です。

つまり、比較値「aaa、bbb～」をデータ一覧のA列から探し出しそのデータを

新しいシートに出力するということですね。

例として出したものはデータ数が１０件ほどしかないからいいものの

実際は１０００件以上の中から対象となるデータを探し出し、

抜き出すという面倒臭いものです。

手作業じゃやってられないですよね…

という訳で、実際にマクロを組んだのでご覧ください。

スポンサードリンク

ソースコード

↓がソースコードです。

こいつをそのまま張り付けてもうまく動かないと思うので、

注意点を記載しておきます。


Sub search()
    
    '対象とするシートの宣言
    
    '検索値があるシート
    Dim targetSheet As Worksheet
    '対象データがあるシート
    Dim seathSheet As Worksheet
    '検索結果を出力するシート
    Dim outputSheet As Worksheet
    
    Set targetSheet = Worksheets(1)
    Set seathSheet = Worksheets(2)
    Set outputSheet = Worksheets(3)
    
    '比較値の最終行取得
    Dim row As Integer
    row = targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).row
    '出力行数
    Dim cnt As Integer: cnt = 2
    
    For i = 2 To row
        '検索結果のセル
        Dim foundCell As Range
        '検索値のセル
        Dim searthCell As Range
        
        Set searthCell = targetSheet.Cells(i, 1)
        '検索値が空白ならスキップ
        If Not searthCell = "" Then
            '検索結果取得
            Set foundCell = seathSheet.Cells.Find(searthCell, LookAt:=xlWhole, SearchOrDer:=xlByColumns)
           
            '検索結果が得られなかった場合スキップ
            If Not foundCell Is Nothing Then
               Set FirstCell = foundCell

               Do
                 '比較値に一致した一覧の行をコピー
                 seathSheet.Rows(foundCell.row).Copy
                 '結果シートに張り付け
                 outputSheet.Rows(cnt).PasteSpecial (xlPasteValues)
                 '結果シートへ張り付ける行を変更するためプラス１
                 cnt = cnt + 1
                 '次を検索
                 Set foundCell = seathSheet.Cells.FindNext(foundCell)
                 
                 '次の検索が最初と同じor存在しなかった場合次の検索値へ
                 If foundCell.Address = FirstCell.Address Then
                     Exit Do
                 ElseIf foundCell Is Nothing Then
                     Exit Do
                 End If
            Loop
                
            End If
        End If
    Next
    
End Sub