Extract multiple rows from another sheet based on cell value

Rant

New Member
Joined
Jul 3, 2021
Messages
11
Office Version
  1. 2019
Platform
  1. Windows
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.

Example:(image)

1640594685896.png


1640594704192.png


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
 

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"

mohadin

Well-known Member
Joined
Mar 22, 2015
Messages
1,692
Office Version
  1. 2013
Platform
  1. Windows
Hi
Try
VBA Code:
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
 
Upvote 0

mohadin

Well-known Member
Joined
Mar 22, 2015
Messages
1,692
Office Version
  1. 2013
Platform
  1. Windows
Or
Your code
VBA 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
 
Upvote 0
Solution

Rant

New Member
Joined
Jul 3, 2021
Messages
11
Office Version
  1. 2019
Platform
  1. Windows
The first one works too. Thank you
 
Upvote 0

Rant

New Member
Joined
Jul 3, 2021
Messages
11
Office Version
  1. 2019
Platform
  1. Windows
Or
Your code
VBA 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
 
Upvote 0

mohadin

Well-known Member
Joined
Mar 22, 2015
Messages
1,692
Office Version
  1. 2013
Platform
  1. Windows
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
 
Upvote 0

mohadin

Well-known Member
Joined
Mar 22, 2015
Messages
1,692
Office Version
  1. 2013
Platform
  1. Windows
Any way my method is some thing like
VBA Code:
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))
 
Upvote 0

mohadin

Well-known Member
Joined
Mar 22, 2015
Messages
1,692
Office Version
  1. 2013
Platform
  1. Windows
VBA Code:
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))
 
Upvote 0

Forum statistics

Threads
1,191,353
Messages
5,986,162
Members
440,007
Latest member
cjw29209

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top