Copy data from sheet 1 to sheet 2 based on day/date
Here is some code that works for me. I started it on row 2 in case you had
headers on row 1.
Option Explicit
Dim Lrow As Long 'finds last row on Day sheet
Dim lRow2 As Long 'finds last row on weekday sheet
Dim rng As Range
Dim c As Range
Dim lDay As Long
Sub CopyToDaysSheet()
Worksheets("Day").Activate
Lrow = Cells(Rows.Count, "B").End(xlUp).Row
Set rng = Range("B2:B" & Lrow) 'change B2 to where your dates start
For Each c In rng
If c.Offset(0, 43).Value = "C" Then 'checks col RS
GoTo 1
Else
lDay = Weekday(c.Value)
Select Case lDay
Case 1
lRow2 = Worksheets("Sunday").Cells(Rows.Count, "B").End(xlUp).Row + 1
c.EntireRow.Copy Destination:=Worksheets("Sunday").Rows(lRow2)
Case 2
lRow2 = Worksheets("Monday").Cells(Rows.Count, "B").End(xlUp).Row + 1
c.EntireRow.Copy Destination:=Worksheets("Monday").Rows(lRow2)
Case 3
lRow2 = Worksheets("Tuesday").Cells(Rows.Count, "B").End(xlUp).Row + 1
c.EntireRow.Copy Destination:=Worksheets("Tuesday").Rows(lRow2)
Case 4
lRow2 = Worksheets("Wednesday").Cells(Rows.Count, "B").End(xlUp).Row + 1
c.EntireRow.Copy Destination:=Worksheets("Wednesday").Rows(lRow2)
Case 5
lRow2 = Worksheets("Thursday").Cells(Rows.Count, "B").End(xlUp).Row + 1
c.EntireRow.Copy Destination:=Worksheets("Thursday").Rows(lRow2)
Case 6
lRow2 = Worksheets("Friday").Cells(Rows.Count, "B").End(xlUp).Row + 1
c.EntireRow.Copy Destination:=Worksheets("Friday").Rows(lRow2)
Case 7
lRow2 = Worksheets("Saturday").Cells(Rows.Count, "B").End(xlUp).Row + 1
c.EntireRow.Copy Destination:=Worksheets("Saturday").Rows(lRow2)
End Select
c.Offset(0, 43).Value = "C" 'marks row as copied
End If
1:
Next c
End Sub
Mike F
wrote in message
oups.com...
mike,
your suggestion sounds good, previously i had tried inserting something
like you suggested in column d (As it is emply) but my programming
skills as rather rusty, can you make any suggestions?
cheers
jon
|