Bonjour,
J'ai un code vba qui me créé un rdv outlook à partir d'un tableau excel.
Cela fonctionne bien mais je dois cliquer sur chaque ligne une par une pour créer le rdv.
J'aimerais qu'il me crée de façon automatique le rdv pour les lignes en dessous si la ligne est complétée.
Comptant sur votre aide

Voici mon code :

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
Function deux(tps)
deux = Right("00" & tps, 2)
End Function
 
Sub rdv()
 
On Error GoTo Erreur
 
Dim fichier As String
 
    Ligne = ActiveCell.Row
    Range("E" & Ligne).Select
    NP = ActiveCell.Value & "_" & ActiveCell.Offset(0, 1).Value
    fichier = ThisWorkbook.Path & "\" & NP & ".ics"
    DT = Split(ActiveCell.Offset(0, 3).Value, "/")
    debut = ActiveCell.Offset(0, 5).Value
    fin = ActiveCell.Offset(0, 6).Value
    DTSTART = DT(2) & DT(1) & DT(0) & "T" & deux(Hour(debut)) & deux(Minute(debut)) & "00"
    DTEND = DT(2) & DT(1) & DT(0) & "T" & deux(Hour(fin)) & deux(Minute(fin)) & "00"
 
    Set f = CreateObject("adodb.stream")
 
    With f
        .Charset = "utf-8"
        .Open
        .WriteText "BEGIN:VCALENDAR" & vbCrLf
        .WriteText "VERSION 2.0" & vbCrLf
        .WriteText "PRODID:-//EXCEL//FR" & vbCrLf
        .WriteText "BEGIN:VEVENT" & vbCrLf
        .WriteText "DTSTART:" & DTSTART & vbCrLf
        .WriteText "DTEND:" & DTEND & vbCrLf
        .WriteText "SUMMARY:" & Niv & vbCrLf
        .WriteText "DESCRIPTION:" & ActiveCell.Offset(0, 7).Value & vbCrLf
        .WriteText "LOCATION:" & ActiveCell.Offset(0, 8).Value & vbCrLf
        .WriteText "END:VEVENT" & vbCrLf
        .WriteText "END:VCALENDAR"
        .SaveToFile fichier, 2
        .Close
 
    End With
    Exit Sub
 
Erreur:
    MsgBox "Il y a un problème avec cette ligne"
 
End Sub