macro to insert rows & copy cells

[Guest]

I need to create rows of data based on days of the week. I start with a
calendar date and delete rows for days of the week where there are no
records. I need to now insert rows based on the remaining days of the week.

Specifically, on Wednesdays, I need to insert 1 row and copy cells from the
row above. On Thursdays and Fridays, I need to insert 3 rows and copy the
respective cells from each day. On Saturdays, I need to insert 4 rows and
copy the cells for Saturday.

This needs to go through the entire data set for one month or two months.
Any ideas?

 

[Guest]

Hi,

Try this which determines day of week from date and inserts/copies
accordingly

HTH

Sub InsertandCopy()

Dim ws1 As Worksheet
Dim r As Long, Lastrow As Long

' Number of inserts for Sunday to Saturday ....
nInserts = Array(0, 0, 0, 1, 3, 3, 4, 0)

Set ws1 = Worksheets("Sheet1")

With ws1

Lastrow = .Cells(Rows.Count, 1).End(xlUp).Row

For r = Lastrow To 2 Step -1
n = nInserts(Weekday(Cells(r, 1)) - 1)
If n <> 0 Then
.Rows(r + 1).Resize(n).Insert Shift:=xlDown
.Rows(r).Copy .Rows(r + 1).Resize(n)
End If
Next r

End With

End Sub

 

[Guest]

Thank you! That worked perfectly!

Hi,

Try this which determines day of week from date and inserts/copies
accordingly

HTH

Sub InsertandCopy()

Dim ws1 As Worksheet
Dim r As Long, Lastrow As Long

' Number of inserts for Sunday to Saturday ....
nInserts = Array(0, 0, 0, 1, 3, 3, 4, 0)

Set ws1 = Worksheets("Sheet1")

With ws1

Lastrow = .Cells(Rows.Count, 1).End(xlUp).Row

For r = Lastrow To 2 Step -1
n = nInserts(Weekday(Cells(r, 1)) - 1)
If n <> 0 Then
.Rows(r + 1).Resize(n).Insert Shift:=xlDown
.Rows(r).Copy .Rows(r + 1).Resize(n)
End If
Next r

End With

End Sub