How to add continuous rows to a table with an incrementing date.

[t0ny84]

Hi All,

I am trying to modify the following macro I found online to suit my requirements, the below code takes the Date from cell N6 and the Appointment from N7 and adds it to the bottom of a table. I am trying to set this up so I can have the option to add in an event multiple times to save having to manipulate the data within the table.

I was thinking of having a drop down list of with Once Off \ Weekly \ Monthly.

Once Off - would add the entry as per the code below.
Weekly - would add the entry to the table and then add 51 more lines to the table with the date being incremented by 7 days
Fortnightly - would add the entry to the table and add 26 more lines to the table with the date being incremented by 14 days.

Sub AddEvent()
Lrow = Worksheets("Schedule").Range("B" & Rows.Count).End(xlUp).Row + 1
Worksheets("Schedule").Range("B" & Lrow) = ActiveSheet.Range("N6")
Worksheets("Schedule").Range("C" & Lrow) = ActiveSheet.Range("M6")
ActiveSheet.Range("M6:N6") = ""
SortTable
End Sub

Thanks in advance!
t0ny84

 

[t0ny84]

Sub AddEvent()
Dim weeklyq As String

If Worksheets("Monthly view").Range("o6") = "Daily" Then
Lrow = Worksheets("Schedule").Range("B" & Rows.Count).End(xlUp).Row + 1
Worksheets("Schedule").Range("B" & Lrow) = ActiveSheet.Range("N6")
Worksheets("Schedule").Range("C" & Lrow) = ActiveSheet.Range("M6")
 
ElseIf Worksheets("Monthly view").Range("o6") = "Weekly" Then
Lrow = Worksheets("Schedule").Range("B" & Rows.Count).End(xlUp).Row + 1
Worksheets("Schedule").Range("B" & Lrow) = ActiveSheet.Range("N6")
Worksheets("Schedule").Range("C" & Lrow) = ActiveSheet.Range("M6")
Worksheets("Schedule").Range("B" & Lrow + 1) = ActiveSheet.Range("N6")
Worksheets("Schedule").Range("C" & Lrow + 1) = ActiveSheet.Range("M6") + 7
Worksheets("Schedule").Range("B" & Lrow + 2) = ActiveSheet.Range("N6")
Worksheets("Schedule").Range("C" & Lrow + 2) = ActiveSheet.Range("M6") + 14

ElseIf Worksheets("Monthly view").Range("o6") = "Fortnightly" Then
Lrow = Worksheets("Schedule").Range("B" & Rows.Count).End(xlUp).Row + 1
Worksheets("Schedule").Range("B" & Lrow) = ActiveSheet.Range("N6")
Worksheets("Schedule").Range("C" & Lrow) = ActiveSheet.Range("M6")
Worksheets("Schedule").Range("B" & Lrow + 1) = ActiveSheet.Range("N6") + 14
Worksheets("Schedule").Range("C" & Lrow + 1) = ActiveSheet.Range("M6") 
Worksheets("Schedule").Range("B" & Lrow + 1) = ActiveSheet.Range("N6") + 28
Worksheets("Schedule").Range("C" & Lrow + 1) = ActiveSheet.Range("M6") 

End If
ActiveSheet.Range("M6:N6") = ""
SortTable
End Sub

 

[t0ny84]

Cross Post - Insert X Rows To Table & Increment Date In Cell - OzGrid Free Excel/VBA Help Forum
Cross Post - Insert X Rows To Table & Increment Date In Cell

 

[t0ny84]

Update - After learning more about LOOPS I was able to mash together the following code (if it might help someone in the future)

Sub AddEvent_modified()
Dim mydate As Date
Dim fdate As String
Dim ix As Integer
Dim cell As Range
Application.ScreenUpdating = False

mydate = Worksheets("Monthly view").Range("M6") 'cell which the user enters the date
fdate = CLng(mydate)
Lrow = Sheet2.Range("B" & Rows.Count).End(xlUp).Row + 1 
lr = Sheet2.Range("B" & Rows.Count).End(xlUp).Row + 1
If IsEmpty(Sheet5.Range("M6")) Or IsEmpty(Sheet5.Range("N6")) Or IsEmpty(Sheet5.Range("o6")) Then 'if a field is left blank
MsgBox "Please review event settings and try again."

ElseIf Sheet5.Range("O6") = "Once Off" Then 'If the event is a once off
Lrow = Sheet2.Range("B" & Rows.Count).End(xlUp).Row + 1
Sheet2.Range("B" & Lrow) = ActiveSheet.Range("N6")
Sheet2.Range("C" & Lrow) = ActiveSheet.Range("M6")
Sheet5.Range("M6:N6") = ""
Exit Sub

ElseIf Sheet5.Range("O6") = "Weekly" Then 'if the event is a weekly event - adds for 52 weeks
For ix = 1 To 52
Sheet2.Range("C" & lr) = fdate
fdate = fdate + 7
lr = lr + 1
Sheet2.Range("B" & Lrow) = Sheet2.Range("N6")
Next ix
Sheet5.Range("M6:N6") = ""
Exit Sub

ElseIf Sheet5.Range("O6") = "Fortnightly" Then 'if the event is a fortnightly event - adds 26 fortnights
For ix = 1 To 27
Sheet2.Range("C" & lr) = fdate
fdate = fdate + 14
lr = lr + 1
Sheet2.Range("B" & Lrow) = Sheet2.Range("N6")
Next ix
Sheet5.Range("M6:N6") = ""
Exit Sub

ElseIf Sheet5.Range("O6") = "Monthly" Then 'if the event is a monthly event - adds 12 months
For ix = 1 To 12
Sheet2.Range("C" & lr) = fdate
fdate = DateAdd("m", 1, fdate)
lr = lr + 1
Sheet2.Range("B" & Lrow) = Sheet2.Range("N6")
Next ix
Sheet5.Range("M6:o6") = ""
End If

Application.ScreenUpdating = True
End Sub