Création/Suppression de RDV outlook via Excel

Bonjour.

J'ai un souci sur une macro faites pas un ancien de chez nous qui fonctionnais parfaitement avant l’installation de office 365 sur nos nouveaux postes (excel 32).

Cette Macro sert à supprimer des RDV sur Outlook via une base de données Excel.

Elle marque maintenant une Erreur 13 au niveau de la ligne "If c <> "" Then"

En tout cas merci d'avance pour votre aide/conseils et bon année à tous.

Voici ci dessous le code utilisé :

    'Variables de fonctionnement
    Dim c As Range    'variable objet Range de la cellue en cours de boucle
    'nécéssite d'activer la référence Microsoft Outlook 10.0 Object Library
    Dim OlApp As New Outlook.Application    'déclaraction et création (New) de l'instance Outlook
    Dim OlMapi As Outlook.Namespace
    Dim OlFolder As Outlook.MAPIFolder
    Dim OlAppointment As Outlook.AppointmentItem
    'Initialisation des variables
    Set OlMapi = OlApp.GetNamespace("MAPI")
    Set OlFolder = OlMapi.GetDefaultFolder(olFolderCalendar)

    'Travail sur la feuille 'Calendrier'
    With Sheets("Calendrier")    'mettre le nom de la feuille en remplacement de Feuil1
        'Parcourir les cellules de la colonne A de la ligne 2 à la dernière ligne occupée
        For Each c In .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp))
            'Si la cellule n'est pas vide
            If c <> "" Then
                'Parcourir les rdv pour voir si le sujet correspond au contenu de la cellule
                For Each OlAppointment In OlFolder.Items
                    'si oui supprimé le rdv
                    If OlAppointment.Subject = c Then OlAppointment.Delete
                Next
            End If
        Next
    End With
    Set OlMapi = Nothing
    Set OlApp = Nothing

Bonjour,

L'erreur 13 est souvent associée une incompatibilité de type.

Sans fichier représentatif, c'est bien difficile à évaluer.

Essaie : If c.text <> "" Then > car, on parle du sujet.

Si pas de changement,

Essaie : If c.value <> "" Then

Sinon, un fichier anonymisé aiderait mieux.

ric

Bonjour Ric.

1000 merci pour le tips.

j'ai rajouté .text quand je copiais des textes et . value pour les chiffres et hop ça refonctionne.

une petit modifs par rapport au vieux excel apparement.

    
 '
 'supression des RDV qui ont la date de debut qui change
 '

    'Variables de fonctionnement
    Dim c As Range    'variable objet Range de la cellue en cours de boucle
    'nécéssite d'activer la référence Microsoft Outlook 16.0 Object Library
    Dim OlApp As New Outlook.Application    'déclaraction et création (New) de l'instance Outlook
    Dim OlMapi As Outlook.Namespace
    Dim OlFolder As Outlook.MAPIFolder
    Dim OlAppointment As Outlook.AppointmentItem
    'Initialisation des variables
    Set OlMapi = OlApp.GetNamespace("MAPI")
    Set OlFolder = OlMapi.GetDefaultFolder(olFolderCalendar)

    'Travail sur la feuille 'Calendrier'
    With Sheets("Calendrier")    'mettre le nom de la feuille en remplacement de Feuil1
        'Parcourir les cellules de la colonne A de la ligne 2 à la dernière ligne occupée
        For Each c In .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp))
            'Si la cellule n'est pas vide
            If c.Text <> "" Then
                'Parcourir les rdv pour voir si le sujet correspond au contenu de la cellule
                For Each OlAppointment In OlFolder.Items
                    'si oui supprimé le rdv
                    If OlAppointment.Subject = c.Text Then OlAppointment.Delete
                Next
            End If
        Next
    End With
    Set OlMapi = Nothing
    Set OlApp = Nothing
 ' Créer un RDV d'Outlook
  Set OutObj = CreateObject("outlook.application")
  ' Avec la feuille
  With Sheets("Calendrier")
    DLig = .Range("A" & Rows.Count).End(xlUp).Row
    ' Pour chaque ligne
    For Lig = 2 To DLig
        ' Importation du RDV
        DateRdv = CDate(Range("B" & Lig))
        Set OutAppt = OutObj.CreateItem(olAppointmentItem)
        With OutAppt
          .Subject = Sheets("Calendrier").Range("A" & Lig).Text
          .Location = Sheets("Calendrier").Range("D" & Lig).Text
          .Start = Sheets("Calendrier").Range("B" & Lig).Value
          .End = Sheets("Calendrier").Range("C" & Lig).Value
          .Duration = Sheets("Calendrier").Range("E" & Lig).Value
          .ReminderSet = False
          .Save
             End With
  Next Lig
  End With
  Set OutAppt = Nothing

Bonjour,

Bien heureux que ça fonctionne.

'nécéssite d'activer la référence Microsoft Outlook 16.0 Object Library

Est-ce que tu sais qu'en déclarant correctement tous les objets nécessaires, tu peux te passer de l'activation de la référence à Microsoft Outlook....

L'avantage : le même fichier peut aisément être utilisé sur une version un peu plus ancienne et les versions nouvelles sans modification ?

ric

Bonjour Ric.

Désolé de ma réponse tardive.

non je ne sais pas du tout comment cela fonctionne.

Mais si tu sais comment faire je suis preneur

Jérôme

Rechercher des sujets similaires à "creation suppression rdv outlook via"