Lege regels overslaan tijdens lezen kolom met datum

Status
Niet open voor verdere reacties.
D

Dozo2000

Gebruiker
Lid geworden
17 nov 2016
Berichten
15
Ik wil graag uit een kolom data inlezen die dan in outlook agenda gezet worden.

Dit gaat totdat er een regel komt, waar geen datum in staat... Dat stop de macro.

Is zoiets "simpel" toe te voegen?
Eventueel met een controle of de datum niet in het verleden ligt en deze dan dus ook overslaat?

Het betreft projecten in een sheet waarbij sommige een vervolgdatum krijgen en andere dus niet.

Alle hulp is welkom!

Code: 
Option Explicit
Public Sub CreateOutlookAppointments()
    On Error GoTo Err_Execute
     
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
     
    Dim i As Long
     
    On Error Resume Next
    Set olApp = Outlook.Application
     
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
     
    On Error GoTo 0
     
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
         
    i = 4
    Do Until Trim(Cells(i, 1).Value) = ""
     
    Set olAppt = CalFolder.Items.Add(olAppointmentItem)
           
    With olAppt
     
        .Start = Cells(i, 20) '+ TimeValue("10:00:00")
        .Subject = Cells(i, 10)
        .Location = Cells(i, 13)
        .Body = Cells(i, 3)
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = 30
        .ReminderSet = True
        .Save
    
    End With
                 
        i = i + 1
        Loop
        
          MsgBox "Reminder aangemaakt in Outlook agenda...", vbMsgBoxSetForeground
         olNs.Logoff
        
    Set olAppt = Nothing
    Set olApp = Nothing
     
    Exit Sub
     
Err_Execute:
    MsgBox "An error occurred."
     
End Sub
 
gebruik:
Code: 
dim cl as range
for each cl in columns(1).specialcells(2).offset(3).specialcells(2)
if  cdate(cl)> date then
........
........
end if
next cl
 
Mijn datum-kolom is "T" en begint in rij 4.

Ik heb het zo aangepast, maar dan wordt er niets gevonden:

Code: 
Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
    
    Dim cl As Range
    For Each cl In Columns(20).SpecialCells(2).Offset(3).SpecialCells(2)
    If CDate(cl) > Date Then
     
    Set olAppt = CalFolder.Items.Add(olAppointmentItem)
           
    With olAppt
     
        .Start = Cells(i, 20) '+ TimeValue("10:00:00")
        .Subject = Cells(i, 10)
        .Location = Cells(i, 13)
        .Body = Cells(i, 3)
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = 30
        .ReminderSet = True
        .Save
    
    End With
                 
        End If
        Next cl
        
          MsgBox "Reminder aangemaakt in Outlook agenda...", vbMsgBoxSetForeground
         olNs.Logoff
        
    Set olAppt = Nothing
    Set olApp = Nothing
     
    Exit Sub

Ik weet niet precies hoe ik de regel moet aanpassen: For Each cl In Columns(20).SpecialCells(2).Offset(3).SpecialCells(2)
Ben nog niet zo lang bezig met macro's.

Alvast bedankt.
 
Je variabele "i" is er niet meer.

Cells(i, 20) wordt cl
Cells(i, 10) wordt cl.offset(,-10)
 
Oh ja natuurlijk is "i" nu weg...

Aangepast, maar toch geen resultaat nog.

"Er zijn geen cellen gevonden." krijg ik nu als melding.
 
Zijn het formules in kolom T ?
Doe het anders zo.
Code: 
For Each cl In range("t4:t"& cells(rows.count,20).end(xlup).row)
 
Ja, het is een berekening van oorspronkelijke datum.
Datum + een week of zo verder en nog eventueel extra dagen erbij.

=ALS(Q4=0;" ";ALS(S4=0;Q4+7;Q4+S4))


Ik krijg nu weer:

Fout 13 tijdens uitvoering:
Typen komen niet met elkaar overeen.
(cl=" ")

Foutopsporing -> If CDate(cl) >= Date Then
 
Plaats het bestand eens.
Anders:
Code: 
if isdate(cl) then
if datevalue(cl)> date then
...
...
end if
end if
Of:
Code: 
if not isempty(cl) then
if datevalue(cl)>date then
 
Helaas kan ik het niet testen daar ik Excel 2016 niet bezit.
De meeste verwijzingen naar de bibliotheek ontbreken.
Doch een poging.
Code: 
Public Sub CreateOutlookAppointments()
  On Error GoTo Err_Execute
    
    Dim cl As Range
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
     
         
    On Error Resume Next
    Set olApp = Outlook.Application
     
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
     
    On Error GoTo 0
     
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
    
  For Each cl In Range("t4:t" & Cells(Rows.Count, 20).End(xlUp).Row)
    If IsDate(cl) Then
    If cl > Date Then
     
    Set olAppt = CalFolder.Items.Add(olAppointmentItem)
           
    With olAppt
     
        .Start = cl + TimeValue("10:00:00")
        .Subject = cl.Offset(, -10)
        .Location = cl.Offset(, -7)
        .Body = cl.Offset(, -16)
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = 30
        .ReminderSet = True
        .Save
    
    End With
                 
        End If
        End If
        
        
         ' MsgBox "Reminder aangemaakt in Outlook agenda...", vbMsgBoxSetForeground
         olNs.Logoff
      Next cl
    Set olAppt = Nothing
    Set olApp = Nothing
     
    Exit Sub
     
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."
     
End Sub
 
Nou, volgens mij werkt het wel, maar nu komen de data niet in de outlook agenda.

Ik heb even als schermuitvoer gebruikt:
Code: 
...
...
  .ReminderMinutesBeforeStart = 30
        .ReminderSet = True
        .Save
    
    End With
                 
        End If
        End If
        
        If IsDate(cl) Then
        If cl > Date Then
        MsgBox cl + TimeValue("10:00:00"), vbMsgBoxSetForeground
        
        End If
        End If
        olNs.Logoff
            
      Next cl
...
...

En alle data in de toekomst worden getoond.
Maar op de één of andere manier is het wegschrijven naar de agenda weg.

Maar zeker weer bedankt!
 
Doorloop de code eens met F8.
Kijk eens of de code bij 'Set olAppt = CalFolder.Items.Add(olAppointmentItem)' komt.

Anders moet ik alles om batterijen naar een ander versie die volgens mij ook werkt op jouw versie om het te testen.
 
Ja, daar komt hij wel.

Hij doorloopt de code 10 keer.
Ik heb dan ook 10 data in de toekomst in de kolom, dus het klopt allemaal wel.

Ik krijg met m'n aangepaste "MsgBox cl" ook 10 keer de juiste datum in beeld en daarna stopt de macro.
 
Voor die tijd werden er wel herinneringen aangemaakt?
 
Ja. Met mijn eerste code wel; van het begin van het bericht.
Alleen daar kwamen alle data in, ook uit het verleden. Totdat er een lege regel kwam.
Dan stopte de macro met een foutcode, maar ik kreeg wel de herinneringen in outlook.


agenda.jpg
 
Test deze code eens.
Code: 
Sub hsv()
Dim cl As Range
 For Each cl In Sheets("Totaal regel overzicht").Range("t4:t" & Cells(Rows.Count, 20).End(xlUp).Row)
   If IsDate(cl) Then
     If DateValue(cl) > Date Then
      With CreateObject("Outlook.Application").CreateItem(1)
        .Start = cl + TimeValue("10:00:00")
        .Subject = cl.Offset(, -10).Value
        .Location = cl.Offset(, -7).Value
        .body = cl.Offset(, -16).Value
        .ReminderMinutesBeforeStart = 30
        .Reminderset = True
        .Save
    
      End With
     End If
    End If
  Next cl
End Sub
 
Hetzelfde.
Met F8 doorgelopen en dan zie ik wel de waarde cl veranderen, maar cl wordt dan ook wel een datum in het verleden.

Ik zie wel een pictogram rechtsonder in beeld dat outlook wordt aangesproken, maar hiermee ook geen herinneringen.
 
Hier worden ze netjes aangemaakt.
Kijk eens rechts in de takenbalk.
 
Je hebt helemaal gelijk!!!

Ik lette eigenlijk alleen maar op het pop-up scherm dat ik normaal steeds kreeg...
Daarin werden dan de herinneringen getoond die al verlopen waren....
Dat scherm gaf niks meer aan, daardoor dacht ik dat ze er niet in kwamen....
Maar ze liggen nu in de toekomst, dus die herinneringen komen natuurlijk nog....
Alle afspraken staan er nu netjes in!!
Super bedankt voor je hulp en je geduld!!!

Ik moet alleen nog even kijken dat hij geen dubbele afspraken gaat aanmaken...

Nogmaals bedankt HSV!!!
 
Of zo:

Code: 
Sub M_snb()
  sn=Sheets("Totaal regel overzicht").cells(1).currentregion

  With CreateObject("Outlook.Application")
     For j=4 to ubound(sn)
       If IsDate(sn(j,20)) Then
         If CDate(sn(j,20)) > Date Then
           with.CreateItem(1)
              .Start = sn(j,20) + 5/12
              .Subject = sn(j,10)
              .Location = sn(j,13)
              .body = sn(j,4)
              .ReminderMinutesBeforeStart = 30
              .Reminderset = True
              .Save
           End With
        End If
      End If
    Next
  end with
End Sub
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan