Re : VBA - Erreur sur rdv outlook
Bonjour à tous,
Un On Error Resume Next juste avant la ligne incriminée... Peut-être.
A+ à tous
Merci mais ça ne fonctionne pas... a moins que je ne sache pas ou le placer...
Pour info voici mon code
Sub ajout()
Dim DateDebut As String
Dim Nom As String
Dim journee As String
Dim sSearch As String
Dim OutlApp As New Outlook.Application
Dim OutlItems As Outlook.Items
Dim OutlAppointment As Outlook.AppointmentItem
Dim MyCalendar As Outlook.Items
Dim OutlMapi As Outlook.Namespace
Dim OutlFolder As Outlook.MAPIFolder
Dim MyItem As Outlook.AppointmentItem
Dim Cell As Range
Dim cal As String
UserForm1.TextBox2.Visible = False
UserForm1.TextBox1.Visible = False 'indique la mise à jour de RDV dans le calendrier
'plage de donnée
For Each Cell In Range("A4:A" & Range("A6000").End(xlUp).Row)
'fin de plage de donnée
'Pour la vérification des doublons on utilise les données suivantes :
If Cell <> "" Then 'recherche dans la plage si il existe des données à inscrire
DateDebut = Cell.Offset(0, 14) & " " & Cell.Offset(0, 15) 'date
Nom = "Relance" & " " & Cell.Offset(0, 0) & " - " & Cell.Offset(0, 1) 'nom
journee = Cell.Offset(0, 6) ' Toute la journée oui/non
'Fin des données pour la valitation de doublon
'Crée la sélection du calendrier dans Outlook
Set OutlApp = CreateObject("Outlook.Application")
Set OutlMapi = OutlApp.GetNamespace("MAPI")
Set OutlFolder = OutlMapi.GetDefaultFolder(olFolderCalendar)
Set OutlItems = OutlFolder.Folders("prospection").Items ' Nom du calendrier - Attention calendrier ajouté en dessous du calendrier par default et nom dans un nouveau groupe.
'Set OutlItems = OutlFolder.Items ' Calendrier par default
'Vérification de doublon pour les rdv
On Error Resume Next
sSearch = "[AllDayEvent] = '" & journee & "' and [Start] = '" & DateDebut & "' and [Subject] = '" & Nom & "'"
Set OutlAppointment = OutlItems.Find(sSearch)
On Error GoTo 0
'fin vérification doublon
If OutlAppointment Is Nothing Then 's'il n'y a pas de doublons lancement du code
'On choisi le calendrier
Set MyCalendar = OutlItems 'choix calendrier
'Fin choix calendrier
UserForm1.TextBox1.Visible = True
Set MyItem = MyCalendar.Add(olAppointmentItem)
With MyItem 'inscription des données dans excel
.MeetingStatus = olNonMeeting 'meeting
.Subject = "Relance" & " " & Cell.Offset(0, 0) & " - " & Cell.Offset(0, 1) 'Sujet
.Start = Cell.Offset(0, 14) & " " & Cell.Offset(0, 15) ' Date plus heure.
.Duration = 30 'durée du RDV en minute"
.Location = Cell.Offset(0, 4) & " - " & Cell.Offset(0, 5) 'emplacement
.AllDayEvent = True ' Toute la journée oui/non
.ReminderSet = True ' S'il y a un rappel
.ReminderMinutesBeforeStart = 1 ' Durée du rappel en minute
.body = Cell.Offset(0, 13) 'Pour les commentaires ou sujets
.Categories = "PROSPECTION"
.Save
End With
Set MyItem = Nothing
UserForm1.TextBox1.Visible = False
Else
GoTo Passe 'Si doublons existant passe à la date suivante
UserForm1.TextBox1.Visible = False
End If
Else
Cell = "" 'si la plage de donnée est vide on quitte le macro
UserForm1.TextBox1.Visible = False
Exit Sub
End If
Passe:
Next Cell 'tant que les cellules de la plage est complete on relance le macro
End Sub