【マクロ・VBA】特定シートと右隣のシート間でマッチングした行を新規シートに貼付け

Sub 検索_行の抽出_ファインド_新規シート貼り付け()

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

Dim rM, rH, rMy, rFirst, rU As Range
     
'検索データがあるシート
Dim targetSheet As Worksheet
    Set targetSheet = Worksheets("検索ﾃﾞｰﾀ")
    
   '検索範囲の指定
    Dim LstRow1 As Long '変数の宣言
    LstRow1 = targetSheet.Cells(Rows.Count, 1).End(xlUp).Row
    Set rH = targetSheet.Range("A1:A" & LstRow1)

 targetSheet.Next.Select
 
'対象データがあるシート
    Dim seathSheet As Worksheet
    Set seathSheet = Worksheets("検索ﾃﾞｰﾀ").Next
    
    '対象範囲の指定
        Dim LstRow2 As Long
        LstRow2 = seathSheet.Cells(Rows.Count, 1).End(xlUp).Row
        Set rU = seathSheet.Range("A1:A" & LstRow2)
    
'③検索結果を出力するシート
Dim Num As Long
On Error Resume Next

Worksheets.Add(After:=ActiveSheet).Name = _
ActiveSheet.Name & "_" & VBA.Format(Now(), "h時mm分ss秒")

Dim outputSheet As Worksheet
    Set outputSheet = ActiveSheet
     
'処理
Dim i As Long
Dim cnt As Long: cnt = 2
      
For i = cnt To LstRow1
    DoEvents
    Dim searthCell As Range
    Set searthCell = targetSheet.Cells(i, 1)
        
    Dim FoundCell As Range
    If Not searthCell = "" Then
        Set FoundCell = rU.Find(searthCell, LookAt:=xlWhole, SearchOrder:=xlByColumns)
            
            Dim firstCell As Range
            If Not FoundCell Is Nothing Then
               Set firstCell = FoundCell
                
                Do
                DoEvents
                         
                    seathSheet.Rows(FoundCell.Row).Copy
                    outputSheet.Rows(cnt).PasteSpecial (xlPasteValues)
            
                    cnt = cnt + 1
                 
                    Set FoundCell = rU.FindNext(FoundCell)
                 
                    If FoundCell.Address = firstCell.Address Then
                    DoEvents
                         Exit Do
                    ElseIf FoundCell Is Nothing Then
                         Exit Do
                    End If
                Loop
                 
            End If
     End If
Next

Application.CutCopyMode = False
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True

ActiveSheet.Range("A2").Select

MsgBox "完了"
End Sub

Sub ファインド_キーワード()
 
    Dim Keyword As String
    Dim FoundCell As Range
    
    Dim firstFoundCell As Range
    
    Dim searchResult As Range
    
    Keyword = "横浜"
    
    'Set foundCell = Cells.Find(What:=Keyword)
    Set FoundCell = ActiveSheet.Range("A2:A1000").Find(What:=Keyword)
    Set firstFoundCell = FoundCell
    
    Set searchResult = FoundCell
    
    Do
        Set FoundCell = Cells.FindNext(FoundCell)
        
        If FoundCell.Address = firstFoundCell.Address Then
           
            Exit Do
        
        Else
            
            Set searchResult = Union(searchResult, FoundCell)
        End If
    Loop
    
    searchResult.Interior.ColorIndex = 27
    
    MsgBox Keyword & "：" & searchResult.Count & "件"
   
    Dim c As Range
    
    Dim cnt As Integer
    
    cnt = 2
    
    For Each c In searchResult
         
         Cells(cnt, "F") = c.Previous.Value
 
         Cells(cnt, "F").Borders.LineStyle = xlContinuous

         cnt = cnt + 1
        
    Next
 MsgBox "完了"
End Sub