While loop to move to next row if while condition is met

[mexaria]

Hi Excel gurus,

I have put a code together (see below - working code with no copyright, fell free to use it) that analyzes an action plan (excel file with columns for actions, date and time of begin and ending of an action etc.) and creates outlook appointments based on the information on the lines of the action plan. The "Evento Criado" condition in the code was created to avoid creating duplicate appointments (if one was already created from a previous macro run).

FYI: Len(Cells(r, 8).Text) --> Column 8 receives planned start dates for an appointment to be created.

I want the code to keep analyzing the lines until the last instance of a planned appointment date on column 8. As it is now, the code stop running when it finds a line where cells(r,8) is blank. I want it to keep going until it finds the last cell in column 8 with a planned start date.

Thank you so much for your help!!
Kevin

r = 7 ' first row with appointment data in the active worksheet
    Dim mysub, myStart, myEnd
    While Len(Cells(r, 8).Text) <> 0
        mysub = Cells(r, 4) & ", " & Cells(r, 5)
        myStart = DateValue(Cells(r, 8).Value) + Cells(r, 9).Value
        myEnd = DateValue(Cells(r, 8).Value) + Cells(r, 10).Value
        'DeleteTestAppointments mysub, myStart, myEnd
        Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
        With olAppItem
        If Cells(r, 14).Value <> "EventoCriado" Then
        ' set default appointment values
            .Location = Cells(r, 7)
            .Body = ""
            .ReminderSet = True
            .BusyStatus = olFree
            '.RequiredAttendees = "johndoe@microsoft.com"
            On Error Resume Next
            .Start = myStart
            .End = myEnd
            .Subject = Cells(r, 5)
            .Attachments.Add ("c:\temp\somefile.msg")
            .Location = Cells(r, 7).Value
            .Body = "A ação a ser realizada é " & Cells(r, 5) & ". Empresa " & Cells(r, 2) & ". Contrato iniciado em " & Cells(r, 1) & ". O serviço relacionado à esta ação é " & Cells(r, 4)
            .ReminderSet = True
            .BusyStatus = olBusy
            .Categories = "Orange Category" ' add this to be able to delete the testappointments
            On Error GoTo 0
            .Save ' saves the new appointment to the default folder
            Cells(r, 14) = "EventoCriado" 'Enter "Done" in Col M when appointment is created
        End If
        End With
        r = r + 1
    Wend

 

[offthelip]

try this simple modification which detects that last row an then sets up a loop from 7 to the last rtow:

Sub test()
lastrow = Cells(Rows.Count, "H").End(xlUp).Row

'r = 7 ' first row with appointment data in the active worksheet
    Dim mysub, myStart, myEnd
'    While Len(Cells(r, 8).Text) <> 0
        For r = 7 To lastrow
        mysub = Cells(r, 4) & ", " & Cells(r, 5)
        myStart = DateValue(Cells(r, 8).Value) + Cells(r, 9).Value
        myEnd = DateValue(Cells(r, 8).Value) + Cells(r, 10).Value
        'DeleteTestAppointments mysub, myStart, myEnd
        Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
        With olAppItem
        If Cells(r, 14).Value <> "EventoCriado" Then
        ' set default appointment values
            .Location = Cells(r, 7)
            .Body = ""
            .ReminderSet = True
            .BusyStatus = olFree
            '.RequiredAttendees = "johndoe@microsoft.com"
            On Error Resume Next
            .Start = myStart
            .End = myEnd
            .Subject = Cells(r, 5)
            .Attachments.Add ("c:\temp\somefile.msg")
            .Location = Cells(r, 7).Value
            .Body = "A ação a ser realizada é " & Cells(r, 5) & ". Empresa " & Cells(r, 2) & ". Contrato iniciado em " & Cells(r, 1) & ". O serviço relacionado à esta ação é " & Cells(r, 4)
            .ReminderSet = True
            .BusyStatus = olBusy
            .Categories = "Orange Category" ' add this to be able to delete the testappointments
            On Error GoTo 0
            .Save ' saves the new appointment to the default folder
            Cells(r, 14) = "EventoCriado" 'Enter "Done" in Col M when appointment is created
        End If
        End With
 '       r = r + 1
 '   Wend
     Next r

End Sub

 

[mexaria]

try this simple modification which detects that last row an then sets up a loop from 7 to the last rtow:

Sub test()
lastrow = Cells(Rows.Count, "H").End(xlUp).Row

'r = 7 ' first row with appointment data in the active worksheet
    Dim mysub, myStart, myEnd
'    While Len(Cells(r, 8).Text) <> 0
        For r = 7 To lastrow
        mysub = Cells(r, 4) & ", " & Cells(r, 5)
        myStart = DateValue(Cells(r, 8).Value) + Cells(r, 9).Value
        myEnd = DateValue(Cells(r, 8).Value) + Cells(r, 10).Value
        'DeleteTestAppointments mysub, myStart, myEnd
        Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
        With olAppItem
        If Cells(r, 14).Value <> "EventoCriado" Then
        ' set default appointment values
            .Location = Cells(r, 7)
            .Body = ""
            .ReminderSet = True
            .BusyStatus = olFree
            '.RequiredAttendees = "johndoe@microsoft.com"
            On Error Resume Next
            .Start = myStart
            .End = myEnd
            .Subject = Cells(r, 5)
            .Attachments.Add ("c:\temp\somefile.msg")
            .Location = Cells(r, 7).Value
            .Body = "A ação a ser realizada é " & Cells(r, 5) & ". Empresa " & Cells(r, 2) & ". Contrato iniciado em " & Cells(r, 1) & ". O serviço relacionado à esta ação é " & Cells(r, 4)
            .ReminderSet = True
            .BusyStatus = olBusy
            .Categories = "Orange Category" ' add this to be able to delete the testappointments
            On Error GoTo 0
            .Save ' saves the new appointment to the default folder
            Cells(r, 14) = "EventoCriado" 'Enter "Done" in Col M when appointment is created
        End If
        End With
'       r = r + 1
'   Wend
     Next r

End Sub

Thanks for the reply.

Your solution generates a type mismatch error '13' in
myStart = DateValue(Cells(r, 8).Value) + Cells(r, 9).Value

Only two data types exist in column 8 (from row 7): either a date or a blank

 

[offthelip]

try adding this check for zero length:

Sub test()
lastrow = Cells(Rows.Count, "H").End(xlUp).Row

'r = 7 ' first row with appointment data in the active worksheet
    Dim mysub, myStart, myEnd
'    While Len(Cells(r, 8).Text) <> 0
     If Len(Cells(r, 8).Text) <> 0 Then

        For r = 7 To lastrow
        mysub = Cells(r, 4) & ", " & Cells(r, 5)
        myStart = DateValue(Cells(r, 8).Value) + Cells(r, 9).Value
        myEnd = DateValue(Cells(r, 8).Value) + Cells(r, 10).Value
        'DeleteTestAppointments mysub, myStart, myEnd
        Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
        With olAppItem
        If Cells(r, 14).Value <> "EventoCriado" Then
        ' set default appointment values
            .Location = Cells(r, 7)
            .Body = ""
            .ReminderSet = True
            .BusyStatus = olFree
            '.RequiredAttendees = "johndoe@microsoft.com"
            On Error Resume Next
            .Start = myStart
            .End = myEnd
            .Subject = Cells(r, 5)
            .Attachments.Add ("c:\temp\somefile.msg")
            .Location = Cells(r, 7).Value
            .Body = "A ação a ser realizada é " & Cells(r, 5) & ". Empresa " & Cells(r, 2) & ". Contrato iniciado em " & Cells(r, 1) & ". O serviço relacionado à esta ação é " & Cells(r, 4)
            .ReminderSet = True
            .BusyStatus = olBusy
            .Categories = "Orange Category" ' add this to be able to delete the testappointments
            On Error GoTo 0
            .Save ' saves the new appointment to the default folder
            Cells(r, 14) = "EventoCriado" 'Enter "Done" in Col M when appointment is created
        End If
        End With
 '       r = r + 1
 '   Wend
       End If
       
     Next r

End Sub

 

[mexaria]

Thanks so much! From your last answer I switched the position of two lines and it worked

Thanks again