Création d'une boucle pour répéter code vba

**Emi1988** · 27/01/2020, 11h40

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

**Qwazerty** · 27/01/2020, 12h13

Salut

Tu peux faire ça comme ça (non testé)

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
47
48
49
50
51
52
53
54
Option Explicit
 
Function deux(tps)
deux = Right("00" & tps, 2)
End Function
 
Sub rdv()
 
'Attention avec ça surtout en phase de développement, si le code plante tu ne le veras pas forcement
On Error GoTo Erreur
 
Dim fichier As String
Dim Ligne As Integer
 
    Ligne = ActiveCell.Row
    While Range("E" & Ligne).Value <> ""
        'On pointe juste la cellule, sans la selectionner physiquement
        With Range("E" & Ligne)
            NP = .Value & "_" & .Offset(0, 1).Value
            fichier = ThisWorkbook.Path & "\" & NP & ".ics"
            DT = Split(.Offset(0, 3).Value, "/")
            debut = .Offset(0, 5).Value
            fin = .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"
 
            'Pense à déclarer les variables ("Option explicit" ajouté en début de module te force à le faire)
            Set f = CreateObject("adodb.stream")
 
            f.Charset = "utf-8"
            f.Open
            f.WriteText "BEGIN:VCALENDAR" & vbCrLf
            f.WriteText "VERSION 2.0" & vbCrLf
            f.WriteText "PRODID:-//EXCEL//FR" & vbCrLf
            f.WriteText "BEGIN:VEVENT" & vbCrLf
            f.WriteText "DTSTART:" & DTSTART & vbCrLf
            f.WriteText "DTEND:" & DTEND & vbCrLf
            f.WriteText "SUMMARY:" & Niv & vbCrLf
            f.WriteText "DESCRIPTION:" & .Offset(0, 7).Value & vbCrLf
            f.WriteText "LOCATION:" & .Offset(0, 8).Value & vbCrLf
            f.WriteText "END:VEVENT" & vbCrLf
            f.WriteText "END:VCALENDAR"
            f.SaveToFile fichier, 2
            f.Close
        End With
        'On passe à la ligne suivante
        Ligne = Ligne + 1
    Wend
    Exit Sub
 
Erreur:
    MsgBox "Il y a un problème avec cette ligne"
 
End Sub

Je te conseille fortement d'utiliser un Tableau Structuré pour stocker des données. Il sera bien plus facile dans le code de boucler sur le contenu du tableau.
A minima précise la feuille sur laquelle tu travailles (FEuil1.Range...)

++
Qwaz

**Emi1988** · 28/01/2020, 10h45

Bonjour,
Merci de ton retour,
Je crois que mon niveau en vba n'est pas suffisant.
Après un 1er essai j'ai le message d'erreur suivant : "Erreur de compilation : tableau attendu "

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
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
Option Explicit
 
Function deux(tps)
deux = Right("00" & tps, 2)
End Function
 
Sub rdv()
 
'Attention avec ça surtout en phase de développement, si le code plante tu ne le veras pas forcement
On Error GoTo Erreur
 
Dim fichier As String
Dim Ligne As Integer
Dim NP As String
Dim DT As Date
Dim debut As Date
Dim fin As Date
Dim DTSTART As Date
Dim DTEND As Date
 
    Ligne = ActiveCell.Row
 
        While ActiveSheet.Range("E" & Ligne).Value <> ""
        'On pointe juste la cellule, sans la selectionner physiquement
        With ActiveSheet.Range("E" & Ligne)
            NP = .Value & "_" & .Offset(0, 1).Value
            fichier = ThisWorkbook.Path & "\" & NP & ".ics"
            DT = Split(.Offset(0, 3).Value, "/")
            debut = .Offset(0, 5).Value
            fin = .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"
 
            'Pense à déclarer les variables ("Option explicit" ajouté en début de module te force à le faire)
            Set f = CreateObject("adodb.stream")
 
            f.Charset = "utf-8"
            f.Open
            f.WriteText "BEGIN:VCALENDAR" & vbCrLf
            f.WriteText "VERSION 2.0" & vbCrLf
            f.WriteText "PRODID:-//EXCEL//FR" & vbCrLf
            f.WriteText "BEGIN:VEVENT" & vbCrLf
            f.WriteText "DTSTART:" & DTSTART & vbCrLf
            f.WriteText "DTEND:" & DTEND & vbCrLf
            f.WriteText "SUMMARY:" & Niv & vbCrLf
            f.WriteText "DESCRIPTION:" & .Offset(0, 7).Value & vbCrLf
            f.WriteText "LOCATION:" & .Offset(0, 8).Value & vbCrLf
            f.WriteText "END:VEVENT" & vbCrLf
            f.WriteText "END:VCALENDAR"
            f.SaveToFile fichier, 2
            f.Close
        End With
        'On passe à la ligne suivante
        Ligne = Ligne + 1
    Wend
    Exit Sub
 
Erreur:
    MsgBox "Il y a un problème avec cette ligne"
 
End Sub

**Qwazerty** · 28/01/2020, 12h19

Salut

Sur quelle ligne?

Peux-tu mettre un fichier anonymisé (sans donnée perso ou confidentiel) ?

++
Qwaz

**Emi1988** · 28/01/2020, 14h20

Ci joint le fichier en question

Voir Module 3.
(le module 2 est le code ok sans boucle)

**OrDonc** · 28/01/2020, 16h41

Bonjour …

Avec DT = Split(.Offset(0, 3).Value, "/"), DT est une matrice (à 1 colonne) donc, pour sa déclaration obligatoire (Option Explicit oblige), écrire Dim DT as Variant.

Penser à F1 pour découvrir Variant

Création d'une boucle pour répéter code vba [XL-365]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager