VBA extract data based on between dates

[djossh]

hi, i would like to extract some data based on the date (Between dates) using userform (date start and date end)
example data below

SHEET1

	A	B	C	D	E
	DATE	REF	CODE	AMT	NAME
1	JAN 2, 2018	AAA	111	25.25	STEVE
2	JAN 7, 2018	ABC	123	654.00	JOHN
3	FEB 6, 2018	DFS	364	215.40	MICHAEL
4	JAN 10, 2018	GSS	571	10.50	KURT
5	MAR 5, 2018	HDS	641	557.10	MIKE
6	FEB 15, 2018	DSE	558	211.20	JOAN
7	FEB 8, 2018	JER	011	321.00	HULK
8	JAN 26, 2018	KYT	317	64.00	SPARK

<tbody>
</tbody>

using my userform :
date start Jan 1, 2018
date end Jan 31, 2018

RESULTS SHOULD BE (NOTE: The column arrangement will be different from the original data)


SHEET2

	A	B	C
	DATE	NAME	AMT
1	JAN 2, 2018	STEVE	25.25
2	JAN 7, 2018	JOHN	654.00
4	JAN 10, 2018	KURT	10.50
8	JAN 26, 2018	SPARK	64.00

<tbody>
</tbody>

thanks in advance for the help

 

[Tim_Excel_]

I would suggest creating a userform with two textboxes that forces the user to write a start and end date in the mm/dd/yyyy format (if that is what your system uses)
<cdate(textbox2.value) then

Sub timechecker()
LRow = ThisWorkbook.Sheets(2).Cells(ThisWorkbook.Sheets(2).Rows.Count, "A").End(xlUp).Row


With ThisWorkbook.Sheets(1)
   LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row


For Each cell In .Range("A2:A" & LastRow)
If cell.Value > cDate(TextBox1.Value) And cell.Value < CDate(TextBox2.Value) Then
.Range("A" & cell.Row & ":E" & cell.Row).Copy ThisWorkbook.Sheets(2).Range("A" & LRow & ":E" & LRow)


End If
Next cell
End With
End Sub

</cdate(textbox2.value)>

 

[kvngrn]

Hi,

try the following and change from your userform the start and end dates from my code Range G1 and H1 set by default

Sub Test()


Dim StartDate As Date, EndDate As Date
Dim RngDate As Range, Rng As Range
Dim LastRow As Integer, k As Integer


'Setup variables


StartDate = Range("G1").Value
EndDate = Range("H1").Value

LastRow = Range("A" & Rows.Count).End(xlUp).Row

Set RngDate = Range("A2:A" & LastRow)

k = 1

For Each Rng In RngDate

If Rng.Value < StartDate Then GoTo Following
If Rng.Value > EndDate Then GoTo Following


Rng.Copy Destination:=Worksheets("Sheet2").Range("A" & k)
Rng.Offset(0, 4).Copy Destination:=Worksheets("Sheet2").Range("A" & k).Offset(0, 1)
Rng.Offset(0, 3).Copy Destination:=Worksheets("Sheet2").Range("A" & k).Offset(0, 2)


k = k + 1

Following:

Next Rng




End Sub

 

[djossh]

Thanks...Don't stop helping others..God Bless

 

[djossh]

is it possible to start/display the results on Rows 20... I need to add some headers and notes above the results.. thanks

 

[Tim_Excel_]

[COLOR=#333333]LRow = ThisWorkbook.Sheets(2).Cells(ThisWorkbook.Sheets(2).Rows.Count, "A").End(xlUp).Row + 20[/COLOR]

 

[djossh]

Hi,

try the following and change from your userform the start and end dates from my code Range G1 and H1 set by default

Sub Test()


Dim StartDate As Date, EndDate As Date
Dim RngDate As Range, Rng As Range
Dim LastRow As Integer, k As Integer


'Setup variables


StartDate = Range("G1").Value
EndDate = Range("H1").Value

LastRow = Range("A" & Rows.Count).End(xlUp).Row

Set RngDate = Range("A2:A" & LastRow)

k = 1

For Each Rng In RngDate

If Rng.Value < StartDate Then GoTo Following
If Rng.Value > EndDate Then GoTo Following


Rng.Copy Destination:=Worksheets("Sheet2").Range("A" & k)
Rng.Offset(0, 4).Copy Destination:=Worksheets("Sheet2").Range("A" & k).Offset(0, 1)
Rng.Offset(0, 3).Copy Destination:=Worksheets("Sheet2").Range("A" & k).Offset(0, 2)


k = k + 1

Following:

Next Rng




End Sub

THANKS it possible to start/display the results In Rows 20... I need to add some headers and notes above the results.. thanks

 

[Tim_Excel_]

Change k=1 to k=20