Extract multiple rows from another sheet based on cell value

[Rant]

Can someone please assist me with a vba code for the following:

I want to assign a code to the load button in sheet2 to extract rows from "Sheet1" into "Sheet 2" based on the the date in cell Sheet2!C2.

Exampleimage)

Unsuccessful in modifying the below code to suit my requirement:
The below code extracts all values in sheet1!Range (A:C) to sheet2!Range (A:C), but I just need to extract the rows that match with the date in Sheet2!C2.

Code:

Private Sub Click()

Dim Sh1 As Worksheet
Dim Sh2 As Worksheet

Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")

Dim lr As Long, lr2 As Long, r As Long

Sh2.Range("A4:C20").Clear
With Sh1
lr = Sh1.Cells(Rows.Count, "A").End(xlUp).Row
lr2 = Sh2.Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 2 Step -1
If IsDate(Sh1.Range("A" & r).Value) Then
Sh1.Range("A" & r & ":C" & r).Copy Destination:=Sh2.Range("A" & lr2 + 1)
lr2 = Sh2.Cells(Rows.Count, "A").End(xlUp).Row

End If
Next r
End With
End Sub

 

[mohadin]

Hi
Try

Sub test()
    Dim a As Variant
    Dim i As Long
    Dim txt, cr
    Application.ScreenUpdating = False
    a = Sheets("sheet1").Range(Sheets("sheet1").Range("A6"), Sheets("sheet1").Range("A6").End(xlDown)).Resize(, 4)
    cr = Sheets("sheet2").Cells(2, 3)
    Sheets("sheet2").Range(Sheets("sheet2").Range("A4"), Sheets("sheet2").Range("A4").End(xlDown)).Resize(, 4).ClearContents
    With CreateObject("scripting.dictionary")
        Dim w(1 To 1, 1 To 4)
        For i = 1 To UBound(a)
            If a(i, 1) = cr Then
                If Not .exists(a(i, 1)) Then
                    txt = (a(i, 1) & "&" & a(i, 2) & "&" & a(i, 3) & "&" & a(i, 4)): .Add a(i, 1), txt
                Else
                    .Item(a(i, 1)) = .Item(a(i, 1)) & "#" & txt
                End If: End If
        Next
        itm = .items
    End With
    itm = Split(itm(0), "#")
    With Sheets("sheet2").Range("a4").Resize(UBound(itm))
        .Value = itm
        .TextToColumns Destination:=Range("A4"), DataType:=xlDelimited, Other:=True, OtherChar:="&", FieldInfo:=Array(4, 1)
    End With
    Application.ScreenUpdating = True
End Sub

 

[mohadin]

Or
Your code

Private Sub Click()
    Dim Sh1 As Worksheet
    Dim Sh2 As Worksheet
    Set Sh1 = Worksheets("Sheet1")
    Set Sh2 = Worksheets("Sheet2")
    Dim lr As Long, lr2 As Long, r As Long
    Sh2.Range("A4:C20").Clear
    lr = Sh1.Cells(Rows.Count, "A").End(xlUp).Row
    lr2 = Sh2.Cells(Rows.Count, "A").End(xlUp).Row
    For r = 1 To lr
        If Sh1.Range("A" & r).Value = Sh2.Range("C2").Value Then
            Sh1.Range("A" & r & ":C" & r).Copy Destination:=Sh2.Range("A" & lr2 + 1)
            lr2 = Sh2.Cells(Rows.Count, "A").End(xlUp).Row
        End If
    Next r
End Sub

 

[Rant]

Thank you. The second code works fine.

 

[Rant]

The first one works too. Thank you

 

[Rant]

Or
Your code

Private Sub Click()
    Dim Sh1 As Worksheet
    Dim Sh2 As Worksheet
    Set Sh1 = Worksheets("Sheet1")
    Set Sh2 = Worksheets("Sheet2")
    Dim lr As Long, lr2 As Long, r As Long
    Sh2.Range("A4:C20").Clear
    lr = Sh1.Cells(Rows.Count, "A").End(xlUp).Row
    lr2 = Sh2.Cells(Rows.Count, "A").End(xlUp).Row
    For r = 1 To lr
        If Sh1.Range("A" & r).Value = Sh2.Range("C2").Value Then
            Sh1.Range("A" & r & ":C" & r).Copy Destination:=Sh2.Range("A" & lr2 + 1)
            lr2 = Sh2.Cells(Rows.Count, "A").End(xlUp).Row
        End If
    Next r
End Sub

Can you please simplify the following code?
The below code seems to be too slow. Is there a way to make it run a bit quicker?

SH1.Range("O" & r).Copy

SH2.Range("A" & lr2 + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats

SH1.Range("K" & r).Copy

SH2.Range("B" & lr2 + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats

SH1.Range("A" & r).Copy

SH2.Range("C" & lr2 + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats

SH1.Range("D" & r).Copy

SH2.Range("D" & lr2 + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats

SH1.Range("L" & r).Copy

SH2.Range("E" & lr2 + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats

SH1.Range("C" & r).Copy

SH2.Range("F" & lr2 + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats

SH1.Range("B" & r).Copy

SH2.Range("G" & lr2 + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats

lr2 = SH2.Cells(Rows.Count, "A").End(xlUp).Row

 

[mohadin]

Sure possible
But as per the forum rules Please start a new thread showing the sample data layout and the result expected would be easier to help

 

[mohadin]

Any way my method is some thing like

a = sh1.Range("A1").Resize(r, 15)
sh2.Range("A1").Resize(UBound(a), 7) = Application.Index(a, Evaluate("row(1:" & UBound(a) & ")"), Array(15, 11, 1, 4, 12, 3))

 

[mohadin]

a = sh1.Range("A1").Resize(r, 15)
sh2.Range("A1").Resize(UBound(a),[B] 6[/B]) = Application.Index(a, Evaluate("row(1:" & UBound(a) & ")"), Array(15, 11, 1, 4, 12, 3))