Excel - Fill with blocks of dates - excel

Question

I am looking to fill a spreadsheet with data repeating data, so 25 appointments for today, 25 appointments for tomorrow with the same name and so on for as far as possible.
Is the a simple way of filling the table where the date increases in blocks of 25?
Example of what i am trying to do

Answer 1

Try using this you might be able to achieve what you want ,any problems shout out
'to change the date to the next day
Public Function ExtraDay(strDate As String)
Dim tDay As Date
tDay = Format(DateAdd("d", 1, strDate), "dd/mm/yy")
ExtraDay = tDay
End Function
'gets the last used row
Function getThelastUsedRowAddress() As Integer
'Get Last Row in Worksheet UsedRange
Dim LastRow As Range, ws As Worksheet
Set ws = ActiveSheet
MsgBox ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
getThelastUsedRowAddress = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
End Function
'button command on the sheet
Private Sub CommandButton1_Click()
Dim n, t As Integer
Dim ns As String
n = getThelastUsedRowAddress()
t = n + n
ns = CStr(t)
Call getThelastUsedRow(CStr(n))
Call TheLoopRange(CStr(n) + 1, ns)
End Sub
'get the last used and paste after
Sub getThelastUsedRow(address As String)
'Get Last Row in Worksheet UsedRange
Dim LastRow As Range, ws As Worksheet
Dim numcopied As Integer
Dim numonpaper As Integer
Set ws = ActiveSheet
numcopied = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
numonpaper = numcopied + 1
ws.UsedRange.Copy 'Destination:=Wst.Cells(1, 1)
'paste
Sheets("Sheet1").Range("A" & numonpaper).PasteSpecial xlPasteValues
End Sub
'loop the pasted range and change date to the next day from date
Sub TheLoopRange(rangestart As String, rangeend As String)
'rangestart,rangeend
Dim rCell As Range
Dim rRng As Range
Set rRng = Sheet1.Range("E" & rangestart & ":E" & rangeend)
For Each rCell In rRng.Cells
'MsgBox rCell.Value
rCell.Value = ExtraDay(rCell.Value)
Next rCell
End Sub

Answer 2

Lets as assume that:
We use Sheet1
Company column is column D
Date column is column I
Pease try:
Option Explicit
Sub Test()
Dim Lastrow As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
Lastrow = .Cells(.Rows.Count, "D").End(xlUp).Row
For i = 2 To Lastrow
If i = 2 Then
.Cells(i, 9).Value = Date + 1
ElseIf i <> 2 And .Cells(i, 4).Value = 1 Then
.Cells(i, 9).Value = .Cells(i, 9).Offset(-1, 0).Value + 1
Else: .Cells(i, 9).Value = .Cells(i, 9).Offset(-1, 0).Value
End If
Next i
End With
End Sub