J
Jazz
Currently this code goes back 1 month to put rows from Information to
Statistics that have dates which are from the previous month. Do you know
how I can make it go only 2 actual months back, so if I were to activate this
macro today, it would only grab dates from November instead of November and
December?
Sub HuntDate()
Dim Cell As Range
Dim CheckDate As Date
Dim DstRng As Range
Dim NextRow As Long
Dim Rng As Range
Dim RngEnd As Range
Dim SrcRng As Range
currentMonth = Month(Date)
Set SrcRng = Worksheets("Information").Range("AS2")
Set DstRng = Worksheets("Statistics").Range("A2")
Set RngEnd = SrcRng.Parent.Cells(Rows.Count, SrcRng.Column).End(xlUp)
Set SrcRng = IIf(RngEnd.Row < SrcRng.Row, SrcRng,
SrcRng.Parent.Range(SrcRng, RngEnd))
Set RngEnd = DstRng.Parent.Cells(Rows.Count, DstRng.Column).End(xlUp)
Set DstRng = IIf(RngEnd.Row < DstRng.Row, DstRng, RngEnd.Offset(1, 0))
For Each Cell In SrcRng
If Cell >= CheckDate And Cell <= Int(Now()) Then
If Rng Is Nothing Then Set Rng = Cell
Set Rng = Union(Rng, Cell)
Cell.EntireRow.Copy DstRng.Offset(NextRow, 0)
NextRow = NextRow + 1
End If
Next Cell
If Not Rng Is Nothing Then Rng.EntireRow.Delete
End Sub
Statistics that have dates which are from the previous month. Do you know
how I can make it go only 2 actual months back, so if I were to activate this
macro today, it would only grab dates from November instead of November and
December?
Sub HuntDate()
Dim Cell As Range
Dim CheckDate As Date
Dim DstRng As Range
Dim NextRow As Long
Dim Rng As Range
Dim RngEnd As Range
Dim SrcRng As Range
currentMonth = Month(Date)
Set SrcRng = Worksheets("Information").Range("AS2")
Set DstRng = Worksheets("Statistics").Range("A2")
Set RngEnd = SrcRng.Parent.Cells(Rows.Count, SrcRng.Column).End(xlUp)
Set SrcRng = IIf(RngEnd.Row < SrcRng.Row, SrcRng,
SrcRng.Parent.Range(SrcRng, RngEnd))
Set RngEnd = DstRng.Parent.Cells(Rows.Count, DstRng.Column).End(xlUp)
Set DstRng = IIf(RngEnd.Row < DstRng.Row, DstRng, RngEnd.Offset(1, 0))
For Each Cell In SrcRng
If Cell >= CheckDate And Cell <= Int(Now()) Then
If Rng Is Nothing Then Set Rng = Cell
Set Rng = Union(Rng, Cell)
Cell.EntireRow.Copy DstRng.Offset(NextRow, 0)
NextRow = NextRow + 1
End If
Next Cell
If Not Rng Is Nothing Then Rng.EntireRow.Delete
End Sub