Macros that Copy and Paste Whole Rows

[Nuccio92]

Is there a way to write a Macro that will look at Sheet 1 and look up the value in D3 and see if it is in Columns F to O in Sheet 2 and if there are matches copying and pasting that whole row from sheet 2 onto sheet 1 at A15. After copying pasting all the ones that matched with D3 than starting with D4 and doing the same thing until D7?

[mehmetcik]

'Is there a way to write a Macro that will look at Sheet 1, D3 to D7
'and see if there are matches in Columns F to O in Sheet 2,
'and if there are matches then copy and paste the whole row to sheet 1 at A15.

Sub test()

LR = 15

For Count = 3 To 7
    If Cells(Count, 4).Value = "" Then GoTo Skip
    strValueToPick = "SELECT"
    With Sheets("Sheet2").Range("F:O")
        Set rngFind = .Find(Cells(Count, 4).Value, .Cells(1, 1), LookIn:=xlValues, lookat:=xlWhole)
        If Not rngFind Is Nothing Then
            strFirstAddress = rngFind.Address
            Set rngPicked = rngFind
            Do
                Set rngPicked = Union(rngPicked, rngFind)
                Set rngFind = .FindNext(rngFind)
            Loop While Not rngFind Is Nothing And rngFind.Address <> strFirstAddress
        End If
    End With
    
    If Not rngPicked Is Nothing Then
    rngPicked.EntireRow.Copy Sheets("Sheet1").Cells(LR, 1)
    End If
    
LR = Cells(Rows.Count, 1).End(xlUp).Row + 1

Skip:

Next

End Sub

[Nuccio92]

Thank you so much! Is there a way to add something in the Macro that will create a Pop Up saying "No Requests for this Seat" if it does not find anything in Sheet 2 that matches it?

[dangelor]

Possibly...

Sub Copy_and_Paste_Whole_Rows()
    Dim vData As Variant
    Dim vFind As Variant
    Dim a As Integer
    Dim b As Long
    Dim c As Integer
    Dim StartRow As Long
    Dim rData As Range
    
    Application.ScreenUpdating = False
    StartRow = 15
    With Worksheets("Sheet2")
        Set rData = Application.Intersect(.Range("F:O"), .UsedRange)
        vData = rData
        vFind = Worksheets("Sheet1").Range("D3:D7")
        For a = LBound(vFind) To UBound(vFind)
            For b = LBound(vData, 1) To UBound(vData, 1)
                For c = LBound(vData, 2) To UBound(vData, 2)
                    If vFind(a, 1) = vData(b, c) Then
                        .Rows(b).Copy Worksheets("Sheet1").Rows(StartRow)
                        StartRow = StartRow + 1
                    End If
                Next c
            Next b
        Next a
    End With
    Application.ScreenUpdating = True
End Sub

[mehmetcik]

Your ammended request is not very clear,

I assume that the seat number you refer to is in Cells D3 to D7

'Is there a way to write a Macro that will look at Sheet 1, D3 to D7
'and see if there are matches in Columns F to O in Sheet 2,
'and if there are matches then copy and paste the whole row to sheet 1 at A15.
'If there are no matches then Messagebox:  "No Requests for this Seat"

Sub test()

LR = 15

For Count = 3 To 7
    If Cells(Count, 4).Value = "" Then GoTo Skip
    strValueToPick = "SELECT"
    With Sheets("Sheet2").Range("F:O")
        Set rngFind = .Find(Cells(Count, 4).Value, .Cells(1, 1), LookIn:=xlValues, lookat:=xlWhole)
        If Not rngFind Is Nothing Then
            strFirstAddress = rngFind.Address
            Set rngPicked = rngFind
            Do
                Set rngPicked = Union(rngPicked, rngFind)
                Set rngFind = .FindNext(rngFind)
            Loop While Not rngFind Is Nothing And rngFind.Address <> strFirstAddress
        End If
    End With
    
    If Not rngPicked Is Nothing Then
    rngPicked.EntireRow.Copy Sheets("Sheet1").Cells(LR, 1)

    Else

    MsgBox "No Requests For Seat:  " & Cells(Count,4).value , vbOKOnly, "No Requests"

    End If
    
LR = Cells(Rows.Count, 1).End(xlUp).Row + 1

Skip:

Next

End Sub