Finding and copying data in VBA

scottmg89

New Member
Joined
Aug 11, 2021
Messages
2
Office Version
  1. 365
Platform
  1. Windows
Hi everyone - I am really stuck and would really appreciate any support that can be offered. I have been stuck on this for ages and tried many different ways but cannot get it to work.
Basically I have multiple sheets of data with dates, names etc and i want to be able to press a button and pull all line entries within a specified date range into one table.
I am trying one sheet at a time of course but when i run the macro, it only pulls in one entry, i suspect the "For" statement is stopping as its found an entry that matches the condition but i want it to find and copy ALL of the entries that match the condition, hope this makes sense. Here is a snippet of the code i am using:

VBA Code:
Sub populate_sprint()

Application.ScreenUpdating = False
 
Dim sprintsht As Worksheet
Dim lr As Long

Set sprintsht = Sheets("Sprint Planner")

'set last row'
lr = sprintsht.Cells(Rows.Count, 2).End(xlUp).Row

'set start date and end date'
Set sd = sprintsht.Range("d5")
Set ed = sprintsht.Range("d7")

'finds tasks in WS1 and copies to sprint planner'

With Sheets("WS1")

For Each cell In .Range("D5", .Range("D" & Rows.Count).End(xlUp))

If cell.Value > sd And cell.Value < ed Then

cell.Offset(0, -3).Copy
Worksheets("WS1").Paste Destination:=sprintsht.Cells(lr + 1, 2)
cell.Offset(0, 7).Copy
Worksheets("WS1").Paste Destination:=sprintsht.Cells(lr + 1, 1)
cell.Offset(0, -2).Copy
Worksheets("WS1").Paste Destination:=sprintsht.Cells(lr + 1, 3)
cell.Offset(0, 1).Copy
Worksheets("WS1").Paste Destination:=sprintsht.Cells(lr + 1, 4)

End If

Next cell

End With

sprintsht.Select


Application.ScreenUpdating = True
 

End Sub
 
Last edited by a moderator:

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,976
Office Version
  1. 2010
Platform
  1. Windows
You just need to add a single line:
VBA Code:
lr=lr+1
here is where to add it:
VBA Code:
For Each cell In .Range("D5", .Range("D" & Rows.Count).End(xlUp))

If cell.Value > sd And cell.Value < ed Then

cell.Offset(0, -3).Copy
Worksheets("WS1").Paste Destination:=sprintsht.Cells(lr + 1, 2)
cell.Offset(0, 7).Copy
Worksheets("WS1").Paste Destination:=sprintsht.Cells(lr + 1, 1)
cell.Offset(0, -2).Copy
Worksheets("WS1").Paste Destination:=sprintsht.Cells(lr + 1, 3)
cell.Offset(0, 1).Copy
Worksheets("WS1").Paste Destination:=sprintsht.Cells(lr + 1, 4)
lr=lr+1                     ' add this line!!!!!!!
End If

Next cell

End With
 
Solution

scottmg89

New Member
Joined
Aug 11, 2021
Messages
2
Office Version
  1. 365
Platform
  1. Windows
You just need to add a single line:
VBA Code:
lr=lr+1
here is where to add it:
VBA Code:
For Each cell In .Range("D5", .Range("D" & Rows.Count).End(xlUp))

If cell.Value > sd And cell.Value < ed Then

cell.Offset(0, -3).Copy
Worksheets("WS1").Paste Destination:=sprintsht.Cells(lr + 1, 2)
cell.Offset(0, 7).Copy
Worksheets("WS1").Paste Destination:=sprintsht.Cells(lr + 1, 1)
cell.Offset(0, -2).Copy
Worksheets("WS1").Paste Destination:=sprintsht.Cells(lr + 1, 3)
cell.Offset(0, 1).Copy
Worksheets("WS1").Paste Destination:=sprintsht.Cells(lr + 1, 4)
lr=lr+1                     ' add this line!!!!!!!
End If

Next cell

End With
Thank you so much! life saver! Good to know i was only one line of code out :)
 

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,976
Office Version
  1. 2010
Platform
  1. Windows
You could speed up your macro by using one or more variant arrays, this code should do the same thing a bit faster because it uses a variant array for the input. You can speed it up more by using an array for the output. If you are doing this for multiple worksheet you might find it is worth speeding it up, because your code is a bit slow.
VBA Code:
With Sheets("WS1")
lastrow = .Cells(Rows.Count, "D").End(xlUp).Row
inarr = .Range(.Cells(1, 1), .Cells(lastrow, 11))

'For Each cell In .Range("D5", .Range("D" & Rows.Count).End(xlUp))
 For i = 1 To lastrow
'If cell.Value > sd And cell.Value < ed Then
 If inarr(i, 4) > sd And inarr(i, 4) < ed Then

sprintsht.Cells(lr + 1, 2) = inarr(i, 1)   ' column A
sprintsht.Cells(lr + 1, 1) = inarr(i, 11) 'column K
sprintsht.Cells(lr + 1, 3) = inarr(i, 2) ' column B
sprintsht.Cells(lr + 1, 4) = inarr(i, 5) ' column E
'cell.Offset(0, -3).Copy
'Worksheets("WS1").Paste Destination:=sprintsht.Cells(lr + 1, 2)
'cell.Offset(0, 7).Copy
'Worksheets("WS1").Paste Destination:=sprintsht.Cells(lr + 1, 1)
'cell.Offset(0, -2).Copy
'Worksheets("WS1").Paste Destination:=sprintsht.Cells(lr + 1, 3)
'cell.Offset(0, 1).Copy
'Worksheets("WS1").Paste Destination:=sprintsht.Cells(lr + 1, 4)
lr = lr +1
End If

Next i
 

Forum statistics

Threads
1,141,293
Messages
5,705,532
Members
421,399
Latest member
hjweiss00

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