Selecting dates from current week with Macro

[Gemz]

Hi,

How can i tell a macro to look in column D, and select the whole row if the
date in column D is a date from the current week? This report is run every
Friday's so i only want the dates from the last 5 days... and then copy and
paste all that info (including all columns (column headers aswell) with the
relevant rows selected) )into another new blank sheet in the same workbook
and call it 'DATE SORTED'.

Thanks a lot.

 

[Mike H]

Gemz

Try this in a module. Alt + F11 to open VB editor. Right click this workbook
and insert module. Paste this in and run it. Change Sheet1 to the correct
source sheet. I have assumed your headers are in row 1.

Sub stance()
Dim myrange, copyrange As Range
Sheets("Sheet2").Select
Lastrow = Cells(Cells.Rows.Count, "D").End(xlUp).Row
Set myrange = Range("D2" & Lastrow)
Set copyrange = Rows(1).EntireRow
For Each c In myrange
If DatePart("ww", c.Value) = DatePart("ww", Now()) Then
Set copyrange = Union(copyrange, c.EntireRow)
End If
Next
copyrange.Copy
Worksheets.Add
ActiveSheet.Name = "DATE SORTED"
Cells(1, 1).Select
ActiveSheet.Paste
End Sub


Mike

 

[Gemz]

Hi,

It highlights the below line and reports error:

If DatePart("ww", c.Value) = DatePart("ww", Now()) Then

Also, i wanted to combine this code with another code that will do something
in the same sheet, i was going to have them as two seperate macros and just
call them both but it might confuse things.

Please let me know if i can combine this code (once working properly) with
the below. They both work in the same way, the below code takes data from
sheet XXX and splits it across 3 sheets depending on criteria and the above
will take data from sheet called 'NOW' and put it in a new sheet called DATA
SORTED - but only copying across rows with dates from current week in column
D. They both need to be in the same workbook - sheets XXX (will be followd by
sheets AAA,BBB,CCC,DDD in workbook) and NOW (will be followed by DATA SORTED
sheet in the SAME WORKBOOK).


Sub splitdata()

AAACol = Array("A", "B", "C")
BBBCol = Array("D", "E")
CCCcol = Array("F")
DDDcol = Array("G", "H")


With ActiveWorkbook
.Worksheets.Add after:=.Sheets(.Sheets.Count)
Set AAA = ActiveSheet
AAA.Name = "AAA"

.Worksheets.Add after:=.Sheets(.Sheets.Count)
Set BBB = ActiveSheet
BBB.Name = "BBB"

.Worksheets.Add after:=.Sheets(.Sheets.Count)
Set CCC = ActiveSheet
CCC.Name = "CCC"

.Worksheets.Add after:=.Sheets(.Sheets.Count)
Set DDD = ActiveSheet
DDD.Name = "DDD"

With Sheets("XXX")
ColCount = 1
For Each col In AAACol
.Columns(col).Copy _
Destination:=AAA.Columns(ColCount)
ColCount = ColCount + 1
Next col

ColCount = 1
For Each col In BBBCol
.Columns(col).Copy _
Destination:=BBB.Columns(ColCount)
ColCount = ColCount + 1
Next col

ColCount = 1
For Each col In CCCCol
.Columns(col).Copy _
Destination:=CCC.Columns(ColCount)
ColCount = ColCount + 1
Next col

ColCount = 1
For Each col In DDDCol
.Columns(col).Copy _
Destination:=DDD.Columns(ColCount)
ColCount = ColCount + 1
Next col

End With
End With

End Sub

i hope im making sense! if its easier to call the macros so they work in
sequence as opposed to combining the code then that is fine too.

Thanks a lot.

 

[Mike H]

gemz,

it hung on that line almost certainly because the value it read from column
D wasn't a date and I was lazy and didn't check for that. Here's the ammended
code that does check. It all worked for me inserted where indicated below.

Mike

Sub stance()
Dim myrange, copyrange As Range
Sheets("Sheet2").Select
Lastrow = Cells(Cells.Rows.Count, "D").End(xlUp).Row
Set myrange = Range("D2" & Lastrow)
Set copyrange = Rows(1).EntireRow
For Each c In myrange
If IsDate(c.Value) Then
If DatePart("ww", c.Value) = DatePart("ww", Now()) Then
Set copyrange = Union(copyrange, c.EntireRow)
End If
End If
Next
copyrange.Copy
Worksheets.Add
ActiveSheet.Name = "DATE SORTED"
Cells(1, 1).Select
ActiveSheet.Paste
End Sub

 

[Gemz]

Thanks that worked great!!

gemz,

it hung on that line almost certainly because the value it read from column
D wasn't a date and I was lazy and didn't check for that. Here's the ammended
code that does check. It all worked for me inserted where indicated below.

Mike

Sub stance()
Dim myrange, copyrange As Range
Sheets("Sheet2").Select
Lastrow = Cells(Cells.Rows.Count, "D").End(xlUp).Row
Set myrange = Range("D2" & Lastrow)
Set copyrange = Rows(1).EntireRow
For Each c In myrange
If IsDate(c.Value) Then
If DatePart("ww", c.Value) = DatePart("ww", Now()) Then
Set copyrange = Union(copyrange, c.EntireRow)
End If
End If
Next
copyrange.Copy
Worksheets.Add
ActiveSheet.Name = "DATE SORTED"
Cells(1, 1).Select
ActiveSheet.Paste
End Sub

 

[Gemz]

Hi, sorry to bother you again but i realised that the macro picks up all
dates in the week (saturday and sunday too) i would only like to see the
5days, from mon-fri. Is there a way to specify this?

Also, i replicated the code for another sheet and found this time instead of
showing 7days (like above even though i would like 5 days) it is showing a
couple of weeks!

Heres the code:

Sub DtRule()
Dim myrange, copyrange As Range
Sheets("Full Database extract").Select
Lastrow = Cells(Cells.Rows.Count, "V").End(xlUp).Row
Set myrange = Range("V2:V" & Lastrow)
Set copyrange = Rows(1).EntireRow
For Each c In myrange
If IsDate(c.Value) Then
If DatePart("ww", c.Value) = DatePart("ww", Now()) Then
Set copyrange = Union(copyrange, c.EntireRow)
End If
End If
Next
copyrange.Copy
Worksheets.Add
ActiveSheet.Name = "info w ending Now()"
Cells(1, 1).Select
ActiveSheet.Paste
End Sub

Also, where it says "info w ending Now()" .. i have put Now() so i can see
the date on the tab name but instead of showing date it just says Now(). How
can i change? and would it be possible to tell the code to autofit columns
when it copies?

thanks a lot for your help.

 

[Gemz]

Can anyone help on the below please. i would really appreciate your help.
thanks.