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

**Qwazerty** · 28/01/2020, 18h02

Salut

Fais un essai avec ça

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
Option Explicit
 
Sub Rdv()
Dim iRowTab As Long
Dim F As Object
Dim FileName As String
 
    'On pointe le tableau Structuré Table1
    With Feuil1.ListObjects("Table1")
        'On boucle sur les lignes du tableau
        For iRowTab = 1 To .ListRows.Count
            'On prépare le nom du fichier
            FileName = ThisWorkbook.Path & "\" & .DataBodyRange(iRowTab, .ListColumns("Nom").Index) & "_" & .DataBodyRange(iRowTab, .ListColumns("Niveau de formation").Index) & ".ics"
            'On crée le Fichier Agenda
            Set F = CreateObject("adodb.stream")
            F.Charset = "utf-8"
            F.Open
            'Entête
            F.WriteText "BEGIN:VCALENDAR" & vbCrLf & "VERSION 2.0" & vbCrLf & "PRODID:-//EXCEL//FR" & vbCrLf & "BEGIN:VEVENT" & vbCrLf
            'DTStart
            F.WriteText "DTSTART:" & Format(.DataBodyRange(iRowTab, .ListColumns("Date de début de formation").Index), "mmddyy") & "T" & Format(.DataBodyRange(iRowTab, .ListColumns("HeureD").Index), "hhmm") & "00"
            'DTEnd
            F.WriteText "DTEND:" & Format(.DataBodyRange(iRowTab, .ListColumns("Date de fin de formation").Index), "mmddyy") & "T" & Format(.DataBodyRange(iRowTab, .ListColumns("HeureF").Index), "hhmm") & "00"
            'D'ou viens Niv?
            F.WriteText "SUMMARY:" & .DataBodyRange(iRowTab, .ListColumns("Niveau de formation").Index) & vbCrLf
            F.WriteText "DESCRIPTION:" & .DataBodyRange(iRowTab, .ListColumns("Nombre de participants").Index) & vbCrLf
            F.WriteText "LOCATION:" & .DataBodyRange(iRowTab, .ListColumns("Adresse du lieu de stage").Index) & vbCrLf
            F.WriteText "END:VEVENT" & vbCrLf & "END:VCALENDAR"
            F.SaveToFile FileName, 2
            F.Close
        Next
    End With
 
End Sub

Tes données sont dans un Tableau Structuré, autant en profiter pour l'utiliser dans le code.
La variable Niv n'était défini nul part, j'imagine qu'il s'agit du niveau de la formation. C'est codé dans ce sens.

++
Qwaz

**Emi1988** · 28/01/2020, 18h02

Super c'est bon ça fonctionne avec le code suivant :

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
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
 
Dim fichier As String
Dim Ligne As Integer
Dim NP As String
Dim DT As Variant
Dim debut As Date
Dim fin As Date
Dim DTSTART As Variant
Dim DTEND As Variant
Dim f As Variant
Dim niv As String
 
    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
 
 
End Sub

et également avec ton code Qwazerty, merci

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

Macros et VBA Excel

Discussions similaires

Partager

Partager