• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Afspraak in gedeelde agenda + afspraken verwijderen

Status
Niet open voor verdere reacties.
Alles op zijn tijd: eerst de ene vraag, dan de andere.
Op basis van wat je eerder formuleerde heeft iedere afspraak een onderscheidend onderwerp in de combinatie van kolom 1, 2 en 3.

Dan kun je dit testen:

Code: 
Sub M_snb_wijzigen()
  On Error Resume Next
  sn = Blad1.Cells(1).CurrentRegion
    
  With CreateObject("outlook.application").GetNamespace("MAPI")
    For j = 2 To UBound(sn)
      With .GetSharedDefaultFolder(.CreateRecipient(sn(j, 13)), 9).Items
        With .Find("[Subject]='" & sn(j, 1) & " " & sn(j, 2) & " " & sn(j, 3) & "'")
          If Err.Number <> 0 Then
            With .add(1)
              .Start = sn(j, 4) + sn(j, 5)
              .Duration = sn(j, 6) - sn(j, 5)
              .Subject = sn(j, 1) & " " & sn(j, 2) & " " & sn(j, 3)
              .Location = sn(j, 9)
              .Body = sn(j, 8)
              .AllDayEvent = sn(j, 10) = "j"
              .ReminderSet = sn(j, 11) = "j"
              .ReminderMinutesBeforeStart = sn(j, 12)
              .Save
            End With
          Else
            .Start = sn(j, 4) + sn(j, 5)
            .Duration = sn(j, 6) - sn(j, 5)
            .Save
          End If
          Err.Clear
        End With
      Next
    End With
End Sub
 
snb zei:
Alles op zijn tijd: eerst de ene vraag, dan de andere.
Op basis van wat je eerder formuleerde heeft iedere afspraak een onderscheidend onderwerp in de combinatie van kolom 1, 2 en 3.
Klik om te vergroten...

Excuus, daar heb je helemaal gelijk in. Deze formule lijkt al super goed te werken. Grote dank voor het versimpelen en het oplossen van dit issue.
Situaties die ik heb getest:
- Alles in dezelfde agenda en alle afspraken wijzigen -> worden netjes geüpdate
- Verschillende agenda's -> wordt een voor een bijgewerkt
- Ik heb toegevoegd:
Code: 
Else
            .Start = sn(j, 4) + sn(j, 5)
            .Duration = sn(j, 6) - sn(j, 5)
            .Location = sn(j, 9)
            .Body = sn(j, 8)
            .AllDayEvent = sn(j, 10) = "j"
            .ReminderSet = sn(j, 11) = "j"
            .ReminderMinutesBeforeStart = sn(j, 12)
            .Save

Dus dat het naar alle velden kijkt op zoek naar wijzigingen. Aanvankelijk werkte de formule niet omdat de next een te hoog stond maar door het een naar beneden te verplaatsen, is het opgelost.
Code: 
  On Error Resume Next
  sn = Blad1.Cells(1).CurrentRegion
    
  With CreateObject("outlook.application").GetNamespace("MAPI")
    For j = 2 To UBound(sn)
      With .GetSharedDefaultFolder(.CreateRecipient(sn(j, 13)), 9).Items
        With .Find("[Subject]='" & sn(j, 1) & " " & sn(j, 2) & " " & sn(j, 3) & "'")
          If Err.Number <> 0 Then
            With .add(1)
              .Start = sn(j, 4) + sn(j, 5)
              .Duration = sn(j, 6) - sn(j, 5)
              .Subject = sn(j, 1) & " " & sn(j, 2) & " " & sn(j, 3)
              .Location = sn(j, 9)
              .Body = sn(j, 8)
              .AllDayEvent = sn(j, 10) = "j"
              .ReminderSet = sn(j, 11) = "j"
              .ReminderMinutesBeforeStart = sn(j, 12)
              .Save
            End With
          Else
            .Start = sn(j, 4) + sn(j, 5)
            .Duration = sn(j, 6) - sn(j, 5)
            .Location = sn(j, 9)
            .Body = sn(j, 8)
            .AllDayEvent = sn(j, 10) = "j"
            .ReminderSet = sn(j, 11) = "j"
            .ReminderMinutesBeforeStart = sn(j, 12)
            .Save
          End If
          Err.Clear
        End With
    End With
    Next
    End With

Het enige wat nog niet lijkt te werken is het volgende. Je hebt bijvoorbeeld 6 afspraken, je gooit er twee van weg. Dan klikt je op de knop afspraken aanpassen:
- Maakt een extra afspraak aan (eentje die mistte)
- Gaat niet door in de loop zodat de tweede ook wordt aangemaakt.
- Bij updaten gaat de formule dus wel alles langs maar bij aanmaken niet.

Het verwijderen is het laatste stukje en dan is het helemaal af.... finally.
Code: 
Sub Afspraak_verwijderen()
  On Error Resume Next
  sn = Blad1.Cells(1).CurrentRegion
 With CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(9)
    For j = 2 To UBound(sn)
    With .GetSharedDefaultFolder(.CreateRecipient(sn(j, 13)), 9).Items
        c00 = Join(Array(sn(j, 1), sn(j, 2), sn(j, 3)))
       .Items(c00).Delete
       End With
       Next
    End With
End Sub
 
Laatst bewerkt:
De laatste:

Code: 
Sub Afspraak_verwijderen()
  On Error Resume Next
  sn = Blad1.Cells(1).CurrentRegion

  With CreateObject("Outlook.Application").GetNamespace("MAPI")
    For j = 2 To UBound(sn)
     .GetSharedDefaultFolder(.CreateRecipient(sn(j, 13)), 9).Items(Join(Array(sn(j, 1), sn(j, 2), sn(j, 3)))).delete
    Next
  End With
End Sub
 
snb zei:
De laatste:

Code: 
Sub Afspraak_verwijderen()
  On Error Resume Next
  sn = Blad1.Cells(1).CurrentRegion

  With CreateObject("Outlook.Application").GetNamespace("MAPI")
    For j = 2 To UBound(sn)
     .GetSharedDefaultFolder(.CreateRecipient(sn(j, 13)), 9).Items(Join(Array(sn(j, 1), sn(j, 2), sn(j, 3)))).delete
    Next
  End With
End Sub
Klik om te vergroten...

Werkt perfect!!!

Grote dank voor het fixen van dit issue. Tips neem ik mee wat betreft debugging en zelf maken van VBA.
 
Laatst bewerkt:
Gebruik de blauwe knop om te reageren, niet de quote knop.
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan