Zeilen Auswahl

Private Sub CommandButton1_Click()
Dim objOutlook As Outlook.Application
Dim apptOutlook As Outlook.AppointmentItem
Range("C5").Select
Do Until ActiveCell.Value = "Ende"
If ActiveCell.Value  "" Then
Set objOutlook = CreateObject("Outlook.Application")
Set apptOutlook = objOutlook.CreateItem(olAppointmentItem)
With apptOutlook
.Subject = ActiveCell.Value
.Start = Format(ActiveCell.Offset(0, -2), "dd.mm.yyyy") & " 08:00"
.Duration = 60
.ReminderMinutesBeforeStart = 1440
.ReminderPlaySound = True
.ReminderSet = True
.Save
End With
End If
ActiveCell.Offset(1, 0).Select
Set apptOutlook = Nothing
Set objOutlook = Nothing
Loop
End Sub