値が一致した行をコピーして最終行に追加するマクロ

概要

・検索値と一致した行をコピーし、結果シートの表の最終行に追加します。
※ 一致する行が、複数でかつ連続にソートされていない場合は、上から一番最初に一致して連続している範囲が対象となります。

【例】

元データ（コピー元）

検索値

出力結果

【実装例】

Sub 条件に一致した行を最終行に追加()
'
' 検索値と一致した行を結果シートにコピーする
'

'画面の再描画/自動計算を停止
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


' 元データがあるシート
Dim masterSheet As Worksheet
' 検索値があるシート
Dim targetSheet As Worksheet
' 結果を出力するシート
Dim outputSheet As Worksheet


Set masterSheet = Worksheets(1)
Set targetSheet = 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 searchCell As Range
    
    ' コピーする対象
    Dim copyRange As Range
    

    
    Set searchCell = targetSheet.Cells(i, 1)
    ' 検索値が空白ならスキップ
    If Not searchCell = "" Then
        ' 検索結果取得
        Set foundCell = masterSheet.Range("A:A").Find(searchCell, Lookat:=xlWhole, SearchOrDer:=xlByColumns)
        
        ' 検索結果が得られなかった場合スキップ
        If Not foundCell Is Nothing Then
            
            ' コピー範囲の行カウンタ
            Dim rowCnt As Long
            rowCnt = 1
            ' 検索結果の行番号
            Dim foundRow As Long
            foundRow = foundCell.row
            
            ' コピーする行の範囲を設定（次の行が同じまでループして行の範囲を設定）
            Do While foundCell.Value = masterSheet.Cells(foundRow + rowCnt, 1).Value
                rowCnt = rowCnt + 1
            Loop
            
            
            ' 対象行をコピー
            Set copyRange = masterSheet.Range(masterSheet.Cells(foundRow, 2), masterSheet.Cells(foundRow + rowCnt - 1, 16))
        Else
            ' 検索値が得られなかった場合は、検索値をコピー
            Set copyRange = searchCell

        End If
        
        ' 結果シートの最終行の次に貼付け
        Dim outputEndRow As Integer
        outputEndRow = outputSheet.Cells(outputSheet.Rows.Count, 2).End(xlUp).Offset(1, 0).row - 1
        
        If (outputEndRow = 3) Then
            outputEndRow = outputEndRow + 1
        End If
        

        ' outputSheet.Range(2, outputRow).PasteSpecial (xlPasteAll)
         copyRange.Copy (outputSheet.Cells(outputEndRow, 2))
         
         outputSheet.Cells(outputEndRow + copyRange.Rows.Count, 2).Value = "XXX"
                  
    End If


Next


      
    
'画面の再描画/自動計算を再開
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
    
    
    
End Sub