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
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]DATE[/TD]
[TD]REF[/TD]
[TD]CODE[/TD]
[TD]AMT[/TD]
[TD]NAME[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]JAN 2, 2018[/TD]
[TD]AAA[/TD]
[TD]111[/TD]
[TD]25.25[/TD]
[TD]STEVE[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]JAN 7, 2018[/TD]
[TD]ABC[/TD]
[TD]123[/TD]
[TD]654.00[/TD]
[TD]JOHN[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]FEB 6, 2018[/TD]
[TD]DFS[/TD]
[TD]364[/TD]
[TD]215.40[/TD]
[TD]MICHAEL[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]JAN 10, 2018[/TD]
[TD]GSS[/TD]
[TD]571[/TD]
[TD]10.50[/TD]
[TD]KURT[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]MAR 5, 2018[/TD]
[TD]HDS[/TD]
[TD]641[/TD]
[TD]557.10[/TD]
[TD]MIKE[/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]FEB 15, 2018[/TD]
[TD]DSE[/TD]
[TD]558[/TD]
[TD]211.20[/TD]
[TD]JOAN[/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]FEB 8, 2018[/TD]
[TD]JER[/TD]
[TD]011[/TD]
[TD]321.00[/TD]
[TD]HULK[/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD]JAN 26, 2018[/TD]
[TD]KYT[/TD]
[TD]317[/TD]
[TD]64.00[/TD]
[TD]SPARK[/TD]
[/TR]
</tbody>[/TABLE]

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
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD="align: center"]A[/TD]
[TD="align: center"]B[/TD]
[TD="align: center"]C[/TD]
[/TR]
[TR]
[TD][/TD]
[TD="align: center"]DATE[/TD]
[TD="align: center"]NAME[/TD]
[TD="align: center"]AMT[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]JAN 2, 2018[/TD]
[TD]STEVE[/TD]
[TD]25.25[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]JAN 7, 2018[/TD]
[TD]JOHN[/TD]
[TD]654.00[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]JAN 10, 2018[/TD]
[TD]KURT[/TD]
[TD]10.50[/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD]JAN 26, 2018[/TD]
[TD]SPARK[/TD]
[TD]64.00[/TD]
[/TR]
</tbody>[/TABLE]


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