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

t0ny84

Board Regular
Joined
Jul 6, 2020
Messages
125
Office Version
  1. 365
  2. 2016
  3. 2013
Platform
  1. Windows
  2. Mobile
  3. Web
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.

VBA Code:
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
 

Some videos you may like

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying

t0ny84

Board Regular
Joined
Jul 6, 2020
Messages
125
Office Version
  1. 365
  2. 2016
  3. 2013
Platform
  1. Windows
  2. Mobile
  3. Web
VBA Code:
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

Board Regular
Joined
Jul 6, 2020
Messages
125
Office Version
  1. 365
  2. 2016
  3. 2013
Platform
  1. Windows
  2. Mobile
  3. Web
Update - After learning more about LOOPS I was able to mash together the following code (if it might help someone in the future)


VBA Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,122,959
Messages
5,599,056
Members
414,281
Latest member
Engjamal2021

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top