Boucle For dans Userform

Version imprimable

Voir 40 message(s) de cette discussion en une page

Bonjour à tous,

Pourriez-vous m'aider ? j'ai un souci dans mon code au niveau de la boucle.

Si je supprime la condition Else en fin de boucle, le code fonctionne mais si la valeur de la combobox n'est pas présente en colonne 4 alors je reçois une erreur.

Avez-vous une idée d'où proviendrait mon erreur ?

Merci d'avance pour votre aide.

Code:

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
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
Private Sub ComboBox13_Change()
Dim date1 As Date, date2 As Date, Duree As Integer, dlng As Integer, i As Integer
Dim rval As String
Dim rpark As String
dlng = Range("C65536").End(xlUp).Row
 
For i = 27 To dlng
If Me.ComboBox13 = "" Then Exit Sub
date1 = Cells(i, 2).Value
date2 = Date
Duree = DateDiff("d", date1, date2)
If Duree > 2 And Cells(i, 4).Value = Me.ComboBox13.Value Then
Cells(i, 9).Value = Duree
rval = Cells(i, 5).Value
rpark = Cells(i, 4).Value
 
Dim strEnvoyer As String
strEnvoyer = "xxxxx@xxxx" ' Mailto: To
Dim OutMail As Object
Dim MonOutlook As Object
Dim MonMessage As Object
Dim strBody As String
Dim strSignature As String
Set MonOutlook = CreateObject("Outlook.Application")
Set MonMessage = MonOutlook.CreateItem(0)
MonMessage.To = strEnvoyer
MonMessage.Subject = "Emergency exit not controlled " & Date
 
    strSignature = MonMessage.HTMLBody
    strBody = strBody & "<table style=width:100%; cellpadding=20; cellspacing=1; border=1>"
    strBody = strBody & "<tr>"
    strBody = strBody & "<th>Parking</th>"
    strBody = strBody & "<th>Emergency exit not controlled</th>"
    strBody = strBody & "<th>Delay</th>"
    strBody = strBody & "</tr>"
    strBody = strBody & "<tr>"
    strBody = strBody & "<td align=center valign=middle>" & Replace(rpark, vbCrLf, "</td>")
    strBody = strBody & "<td align=center valign=middle>" & Replace(rval, vbCrLf, "</td>")
    strBody = strBody & "<td align=center valign=middle>" & Replace(Duree, vbCrLf, "</td>")
    strBody = strBody & "</tr>"
    strBody = strBody & "</table>"
Else
If Me.ComboBox13.Value <> Cells(i, 4).Value Then
   GoTo demande1
End If
End If
 
Next i
 
strBody = strBody & "<p style font-family=courier; font-size=24; style=color:#090909>" & "<b>" & "Best regards</b></p>"
strBody = strBody & "<p style font-family=courier; font-size=24; style=color:#090909>" & UCase(Environ("USERNAME"))
MonMessage.HTMLBody = strBody
ThisWorkbook.Save
MonMessage.Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
MonMessage.send
Set MonOutlook = Nothing
 
demande1:
'Cherche la première ligne vide
lig = Range("B" & Rows.Count).End(xlUp).Row + 1
'Copie le parking choisi dans la colonne D
Cells(lig, 4) = Me.ComboBox13
If Me.ComboBox13 <> "" Then
    'Met la date et l'heure dans les colonne B et C
    Me.TextBox55 = Date: Cells(lig, 2) = Me.TextBox55
    Me.TextBox103 = Time: Cells(lig, 3) = Me.TextBox103
Else
    Exit Sub
End If
'Description de la sortie de secours
EMERGENCY_EXIT = InputBox("Please enter the name of the emergency exit ", "Emergency exit ?")
Me.TextBox57 = EMERGENCY_EXIT: Cells(lig, 5) = EMERGENCY_EXIT
If Me.TextBox57 <> "" Then
Cells(lig, 6) = "True"
Else
Cells(lig, 6) = "False"
End If
 
'CHECKED BY
CHECKED_BY = InputBox("Please enter the name of the person who made the control ?")
Me.TextBox60 = CHECKED_BY: Cells(lig, 7) = CHECKED_BY
 
'Commentaires
Comments = InputBox("please enter your comments ?")
Me.TextBox59 = Comments: Cells(lig, 8) = Comments
 
End Sub

22/06/2016, 16h05
parmi

Bonjour,

De quel Else parles-tu ? et sur quelle ligne apparaît l'erreur ?
PS: quand tu mets du code utilise le bouton # pour le formater et le rendre plus lisible...

1 pièce(s) jointe(s)

Bonjour,

Merci pour ton aide.

Voici le message d'erreur. Si je supprime cette condition:

Code:

1
2
3
4
Else
If Me.ComboBox13.Value <> Cells(i, 4).Value Then
   GoTo demande1
End If

Pièce jointe 213654

Par contre si la valeur de ma combobox est bien dans mon tableau en colonne 4 alors tout fonctionne et le mail est envoyé.

Bien à toi,

voici mon code :

Code:

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
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
Private Sub ComboBox13_Change()
Dim date1 As Date, date2 As Date, Duree As Integer, dlng As Integer, i As Integer
Dim rval As String
Dim rpark As String
dlng = Range("C65536").End(xlUp).Row
 
For i = 27 To dlng
If Me.ComboBox13 = "" Then Exit Sub
date1 = Cells(i, 2).Value
date2 = Date
Duree = DateDiff("d", date1, date2)
If Duree > 2 And Cells(i, 4).Value = Me.ComboBox13.Value Then
Cells(i, 9).Value = Duree
rval = Cells(i, 5).Value
rpark = Cells(i, 4).Value
 
Dim strEnvoyer As String
strEnvoyer = "xxxxx@xxxx" ' Mailto: To
Dim OutMail As Object
Dim MonOutlook As Object
Dim MonMessage As Object
Dim strBody As String
Dim strSignature As String
Set MonOutlook = CreateObject("Outlook.Application")
Set MonMessage = MonOutlook.CreateItem(0)
MonMessage.To = strEnvoyer
MonMessage.Subject = "Emergency exit not controlled " & Date
 
    strSignature = MonMessage.HTMLBody
    strBody = strBody & "<table style=width:100%; cellpadding=20; cellspacing=1; border=1>"
    strBody = strBody & "<tr>"
    strBody = strBody & "<th>Parking</th>"
    strBody = strBody & "<th>Emergency exit not controlled</th>"
    strBody = strBody & "<th>Delay</th>"
    strBody = strBody & "</tr>"
    strBody = strBody & "<tr>"
    strBody = strBody & "<td align=center valign=middle>" & Replace(rpark, vbCrLf, "</td>")
    strBody = strBody & "<td align=center valign=middle>" & Replace(rval, vbCrLf, "</td>")
    strBody = strBody & "<td align=center valign=middle>" & Replace(Duree, vbCrLf, "</td>")
    strBody = strBody & "</tr>"
    strBody = strBody & "</table>"
Else
If Me.ComboBox13.Value <> Cells(i, 4).Value Then
   GoTo demande1
End If
End If
 
Next i
 
strBody = strBody & "<p style font-family=courier; font-size=24; style=color:#090909>" & "<b>" & "Best regards</b></p>"
strBody = strBody & "<p style font-family=courier; font-size=24; style=color:#090909>" & UCase(Environ("USERNAME"))
MonMessage.HTMLBody = strBody
ThisWorkbook.Save
MonMessage.Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
MonMessage.send
Set MonOutlook = Nothing
 
demande1:
'Cherche la première ligne vide
lig = Range("B" & Rows.Count).End(xlUp).Row + 1
'Copie le parking choisi dans la colonne D
Cells(lig, 4) = Me.ComboBox13
If Me.ComboBox13 <> "" Then
    'Met la date et l'heure dans les colonne B et C
    Me.TextBox55 = Date: Cells(lig, 2) = Me.TextBox55
    Me.TextBox103 = Time: Cells(lig, 3) = Me.TextBox103
Else
    Exit Sub
End If
'Description de la sortie de secours
EMERGENCY_EXIT = InputBox("Please enter the name of the emergency exit ", "Emergency exit ?")
Me.TextBox57 = EMERGENCY_EXIT: Cells(lig, 5) = EMERGENCY_EXIT
If Me.TextBox57 <> "" Then
Cells(lig, 6) = "True"
Else
Cells(lig, 6) = "False"
End If
 
'CHECKED BY
CHECKED_BY = InputBox("Please enter the name of the person who made the control ?")
Me.TextBox60 = CHECKED_BY: Cells(lig, 7) = CHECKED_BY
 
'Commentaires
Comments = InputBox("please enter your comments ?")
Me.TextBox59 = Comments: Cells(lig, 8) = Comments
 
End Sub

OK, tu initialises tom Message à l'intérieur de ta boucle si la condition est vraie

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
If Duree > 2 And Cells(i, 4).Value = Me.ComboBox13.Value Then
Cells(i, 9).Value = Duree
rval = Cells(i, 5).Value
rpark = Cells(i, 4).Value
 
Dim strEnvoyer As String
strEnvoyer = "xxxxx@xxxx" ' Mailto: To
Dim OutMail As Object
Dim MonOutlook As Object
Dim MonMessage As Object
Dim strBody As String
Dim strSignature As String
Set MonOutlook = CreateObject("Outlook.Application")
Set MonMessage = MonOutlook.CreateItem(0)
'................

Si la condition est fausse, MonMessage et MonOutlook ne sont pas initialisés et ça cause une erreur.
Tu pourrais initialiser à l'extérieur de la condition

Code:

1
2
3
4
5
6
7
8
9
For i = 27 To dlng
   If Me.ComboBox13 = "" Then Exit Sub
      date1 = Cells(i, 2).Value
      date2 = Date
      Duree = DateDiff("d", date1, date2)
      Set MonOutlook = CreateObject("Outlook.Application")
      Set MonMessage = MonOutlook.CreateItem(0)
   If Duree > 2 And Cells(i, 4).Value = Me.ComboBox13.Value Then
'.....

Et habitue-toi à déclarer toutes les variables en entête de procédure

Bonsoir,

Je pensais que c'était réglé mais maintenant je n'ai plus le mail qui est envoyé.

Ci-dessous le code adapté :

Code:

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
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
Private Sub ComboBox13_Change()
Dim date1 As Date, date2 As Date, Duree As Integer, dlng As Integer, i As Integer
Dim rval As String
Dim rpark As String
Dim strEnvoyer As String
Dim OutMail As Object
Dim MonOutlook As Object
Dim MonMessage As Object
Dim strBody As String
Dim strSignature As String
 
dlng = Range("C65536").End(xlUp).Row
 
For i = 27 To dlng
If Me.ComboBox13 = "" Then Exit Sub
date1 = Cells(i, 2).Value
date2 = Date
Duree = DateDiff("d", date1, date2)
Set MonOutlook = CreateObject("Outlook.Application")
Set MonMessage = MonOutlook.CreateItem(0)
If Duree > 2 And Cells(i, 4).Value = Me.ComboBox13.Value Then
Cells(i, 9).Value = Duree
rval = Cells(i, 5).Value
rpark = Cells(i, 4).Value
 
 
strEnvoyer = "xxxxxx" ' Mailto: To
MonMessage.To = strEnvoyer
MonMessage.Subject = "Emergency exit not controlled " & Date
 
    strSignature = MonMessage.HTMLBody
    strBody = strBody & "<table style=width:100%; cellpadding=20; cellspacing=1; border=1>"
    strBody = strBody & "<tr>"
    strBody = strBody & "<th>Parking</th>"
    strBody = strBody & "<th>Emergency exit not controlled</th>"
    strBody = strBody & "<th>Delay</th>"
    strBody = strBody & "</tr>"
    strBody = strBody & "<tr>"
    strBody = strBody & "<td align=center valign=middle>" & Replace(rpark, vbCrLf, "</td>")
    strBody = strBody & "<td align=center valign=middle>" & Replace(rval, vbCrLf, "</td>")
    strBody = strBody & "<td align=center valign=middle>" & Replace(Duree, vbCrLf, "</td>")
    strBody = strBody & "</tr>"
    strBody = strBody & "</table>"
Else
If Me.ComboBox13.Value <> Cells(i, 4).Value Then
   GoTo demande1
End If
End If
 
Next i
 
strBody = strBody & "<p style font-family=courier; font-size=24; style=color:#090909>" & "<b>" & "Best regards</b></p>"
strBody = strBody & "<p style font-family=courier; font-size=24; style=color:#090909>" & UCase(Environ("USERNAME"))
MonMessage.HTMLBody = strBody
ThisWorkbook.Save
MonMessage.Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
MonMessage.send
Set MonOutlook = Nothing
 
demande1:
'Cherche la première ligne vide
lig = Range("B" & Rows.Count).End(xlUp).Row + 1
'Copie le parking choisi dans la colonne D
Cells(lig, 4) = Me.ComboBox13
If Me.ComboBox13 <> "" Then
    'Met la date et l'heure dans les colonne B et C
    Me.TextBox55 = Date: Cells(lig, 2) = Me.TextBox55
    Me.TextBox103 = Time: Cells(lig, 3) = Me.TextBox103
Else
    Exit Sub
End If
'Description de la sortie de secours
EMERGENCY_EXIT = InputBox("Please enter the name of the emergency exit ", "Emergency exit ?")
Me.TextBox57 = EMERGENCY_EXIT: Cells(lig, 5) = EMERGENCY_EXIT
If Me.TextBox57 <> "" Then
Cells(lig, 6) = "True"
Else
Cells(lig, 6) = "False"
End If
 
'CHECKED BY
CHECKED_BY = InputBox("Please enter the name of the person who made the control ?")
Me.TextBox60 = CHECKED_BY: Cells(lig, 7) = CHECKED_BY
 
'Commentaires
Comments = InputBox("please enter your comments ?")
Me.TextBox59 = Comments: Cells(lig, 8) = Comments
 
End Sub

petite précision code a bien été testé avec une adresse mail valide

Code:

strEnvoyer = "xxxxxx@xxxxx" ' Mailto: To

22/06/2016, 21h57
parmi

Si ça ne fonctionne pas, passe en pas à pas (F8) et regarde la valeur de tes différentes variables pour comprendre ce qui ne va pas.

en vérifiant avec F8, Je n'ai pas de valeur à cette ligne :

Code:

Set MonMessage = MonOutlook.CreateItem(0)

Bizarrement sans la condition suivante et adapté comme ci-dessous alors le mail est envoyé que si la valeur de la combobox est trouvé en colonne 4 sinon je reçois une erreur.

Code:

1
2
3
4
Else
If Me.ComboBox13.Value <> Cells(i, 4).Value Then
   GoTo demande1
End If

code adapté :

Code:

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
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
Private Sub ComboBox13_Change()
Dim date1 As Date, date2 As Date, Duree As Integer, dlng As Integer, i As Integer
Dim rval As String
Dim rpark As String
 
dlng = Range("C65536").End(xlUp).Row
 
For i = 27 To dlng
If Me.ComboBox13 = "" Then Exit Sub
date1 = Cells(i, 2).Value
date2 = Date
Duree = DateDiff("d", date1, date2)
 
If Duree > 2 And Cells(i, 4).Value = Me.ComboBox13.Value Then
Cells(i, 9).Value = Duree
rval = Cells(i, 5).Value
rpark = Cells(i, 4).Value
 
 
 
Dim strEnvoyer As String
strEnvoyer = "xxxxxxxxx" ' Mailto: To
Dim OutMail As Object
Dim MonOutlook As Object
Dim MonMessage As Object
Dim strBody As String
Dim strSignature As String
Set MonOutlook = CreateObject("Outlook.Application")
Set MonMessage = MonOutlook.CreateItem(0)
MonMessage.To = strEnvoyer
MonMessage.Subject = "Emergency exit not controlled " & Date
 
    strSignature = MonMessage.HTMLBody
    strBody = strBody & "<table style=width:100%; cellpadding=20; cellspacing=1; border=1>"
    strBody = strBody & "<tr>"
    strBody = strBody & "<th>Parking</th>"
    strBody = strBody & "<th>Emergency exit not controlled</th>"
    strBody = strBody & "<th>Delay</th>"
    strBody = strBody & "</tr>"
    strBody = strBody & "<tr>"
    strBody = strBody & "<td align=center valign=middle>" & Replace(rpark, vbCrLf, "</td>")
    strBody = strBody & "<td align=center valign=middle>" & Replace(rval, vbCrLf, "</td>")
    strBody = strBody & "<td align=center valign=middle>" & Replace(Duree, vbCrLf, "</td>")
    strBody = strBody & "</tr>"
    strBody = strBody & "</table>"
 
End If
 
Next i
 
strBody = strBody & "<p style font-family=courier; font-size=24; style=color:#090909>" & "<b>" & "Best regards</b></p>"
strBody = strBody & "<p style font-family=courier; font-size=24; style=color:#090909>" & UCase(Environ("USERNAME"))
MonMessage.HTMLBody = strBody
ThisWorkbook.Save
MonMessage.Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
MonMessage.send
Set MonOutlook = Nothing
 
demande1:
'Cherche la première ligne vide
lig = Range("B" & Rows.Count).End(xlUp).Row + 1
'Copie le parking choisi dans la colonne D
Cells(lig, 4) = Me.ComboBox13
If Me.ComboBox13 <> "" Then
    'Met la date et l'heure dans les colonne B et C
    Me.TextBox55 = Date: Cells(lig, 2) = Me.TextBox55
    Me.TextBox103 = Time: Cells(lig, 3) = Me.TextBox103
Else
    Exit Sub
End If
'Description de la sortie de secours
EMERGENCY_EXIT = InputBox("Please enter the name of the emergency exit ", "Emergency exit ?")
Me.TextBox57 = EMERGENCY_EXIT: Cells(lig, 5) = EMERGENCY_EXIT
If Me.TextBox57 <> "" Then
Cells(lig, 6) = "True"
Else
Cells(lig, 6) = "False"
End If
 
'CHECKED BY
CHECKED_BY = InputBox("Please enter the name of the person who made the control ?")
Me.TextBox60 = CHECKED_BY: Cells(lig, 7) = CHECKED_BY
 
'Commentaires
Comments = InputBox("please enter your comments ?")
Me.TextBox59 = Comments: Cells(lig, 8) = Comments
 
End Sub

23/06/2016, 00h21
parmi

Je pense qu'il y a un mauvaise conception dans la boucle et les conditions.
Sans voir le classeur, c'est difficile à pointer le problème.
Il faut que tu vérifies toutes les variables, voir si elles retournent bien les valeurs que tu souhaites,...
23/06/2016, 00h31
vincent007

1 pièce(s) jointe(s)

Bonsoir Parmi,

Merci pour ton aide.

Voici le fichier.

Bien à toi

Essaie en changeant comme ceci (pas testé, mais plus lisible en tout cas...)
Comme je disais, place tes variables en début de procédure, sinon elles ne sont pas nécessairement reconnues en dehors des conditions.
Et habitue-toi à indenter ton code pour une meilleure lisibilité.

Et évite de mettre tout un tas de variables en entête de code. Ça te réserve de mauvaises surprises...

Code:

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
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
Private Sub ComboBox13_Change()
    Dim date1 As Date, date2 As Date, Duree As Integer, dlng As Integer, i As Integer
    Dim rval As String
    Dim rpark As String
    Dim strEnvoyer As String
    Dim OutMail As Object
    Dim MonOutlook As Object
    Dim MonMessage As Object
    Dim strBody As String
    Dim strSignature As String
 
    Set MonOutlook = CreateObject("Outlook.Application")
    Set MonMessage = MonOutlook.CreateItem(0)
 
    dlng = Range("C65536").End(xlUp).Row
 
    For i = 27 To dlng
        If Me.ComboBox13 = "" Then Exit Sub
        date1 = Cells(i, 2).Value
        date2 = Date
        Duree = DateDiff("d", date1, date2)
 
        If Duree > 2 And Cells(i, 4).Value = Me.ComboBox13.Value Then
            Cells(i, 9).Value = Duree
            rval = Cells(i, 5).Value
            rpark = Cells(i, 4).Value
 
            strEnvoyer = "vrousseau@interparking.com" ' Mailto: To
            MonMessage.To = strEnvoyer
            MonMessage.Subject = "Emergency exit not controlled " & Date
 
            strSignature = MonMessage.HTMLBody
            strBody = strBody & "<table style=width:100%; cellpadding=20; cellspacing=1; border=1>"
            strBody = strBody & "<tr>"
            strBody = strBody & "<th>Parking</th>"
            strBody = strBody & "<th>Emergency exit not controlled</th>"
            strBody = strBody & "<th>Delay</th>"
            strBody = strBody & "</tr>"
            strBody = strBody & "<tr>"
            strBody = strBody & "<td align=center valign=middle>" & Replace(rpark, vbCrLf, "</td>")
            strBody = strBody & "<td align=center valign=middle>" & Replace(rval, vbCrLf, "</td>")
            strBody = strBody & "<td align=center valign=middle>" & Replace(Duree, vbCrLf, "</td>")
            strBody = strBody & "</tr>"
            strBody = strBody & "</table>"
 
 
        End If
 
    Next i
 
    strBody = strBody & "<p style font-family=courier; font-size=24; style=color:#090909>" & "<b>" & "Best regards</b></p>"
    strBody = strBody & "<p style font-family=courier; font-size=24; style=color:#090909>" & UCase(Environ("USERNAME"))
 
    MonMessage.HTMLBody = strBody
    ThisWorkbook.Save
    MonMessage.Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
    MonMessage.send
    Set MonOutlook = Nothing
    Set MonMessage = Nothing
 
demande1:
    'Cherche la première ligne vide
    lig = Range("B" & Rows.Count).End(xlUp).Row + 1
 
    'Copie le parking choisi dans la colonne D
    Cells(lig, 4) = Me.ComboBox13
    If Me.ComboBox13 <> "" Then
        'Met la date et l'heure dans les colonne B et C
        Me.TextBox55 = Date: Cells(lig, 2) = Me.TextBox55
        Me.TextBox103 = Time: Cells(lig, 3) = Me.TextBox103
    Else
        Exit Sub
    End If
 
    'Description de la sortie de secours
    EMERGENCY_EXIT = InputBox("Please enter the name of the emergency exit ", "Emergency exit ?")
    Me.TextBox57 = EMERGENCY_EXIT: Cells(lig, 5) = EMERGENCY_EXIT
    If Me.TextBox57 <> "" Then
        Cells(lig, 6) = "True"
    Else
        Cells(lig, 6) = "False"
    End If
 
    'CHECKED BY
    CHECKED_BY = InputBox("Please enter the name of the person who made the control ?")
    Me.TextBox60 = CHECKED_BY: Cells(lig, 7) = CHECKED_BY
 
    'Commentaires
    Comments = InputBox("please enter your comments ?")
    Me.TextBox59 = Comments: Cells(lig, 8) = Comments
 
End Sub

23/06/2016, 12h15
vincent007

1 pièce(s) jointe(s)
Bonjour,

J'ai testé cela fonctionne si la valeur de ma combobox se trouve en colonne 4 si non je reçois cette erreur :

Pièce jointe 213729

Et si je rajoute cette condition :
Code:

1 2 3 4 Else If Me.ComboBox13.Value <> Cells(i, 4).Value Then GoTo demande1 End If
Alors je n'ai plus l'erreur mais le mail n'est pas envoyé. =-(

???

Met cette partie en haut

Citation:

strEnvoyer = "vrousseau@interparking.com" ' Mailto: To
MonMessage.To = strEnvoyer
MonMessage.Subject = "Emergency exit not controlled " & Date

Comme ceci
Code:

1 2 3 4 5 Set MonOutlook = CreateObject("Outlook.Application") Set MonMessage = MonOutlook.CreateItem(0) strEnvoyer = "vrousseau@interparking.com" ' Mailto: To MonMessage.To = strEnvoyer MonMessage.Subject = "Emergency exit not controlled " & Date
Si, au lieu de mettre .Send, tu mets .Display, tu vas t'apercevoir pourquoi le message ne s’envoie pas, même s'il est créé.

Re,

Oui maintenant le mail est envoyé dans tout les cas, hors je voudrais que le mail soit envoyé uniquement si la condition suivant est vrai :

Code:

1
2
Duree = DateDiff("d", date1, date2)
If Duree > 2 And Cells(i, 4).Value = Me.ComboBox13.Value

Dans le cas contraire le mail ne doit pas être envoyé.

Tu comprends ?

Merci pour ton aide

J'ai ajouté la condition suivante et cela fonctionne :

Code:

1
2
3
4
Else
         If Duree < 2 And Me.ComboBox13.Value <> Cells(i, 4).Value Then
            GoTo demande1
         End If

Mais ensuite lorsque clique sur next afin de vider le contenu de mes textbox et combobox et que je recharge une valeur dans la combobox cela ne fonctionne plus, le mail n'est pas envoyé.

code complet :

Code:

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
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
Private Sub ComboBox13_Change()
Dim date1 As Date, date2 As Date, Duree As Integer, dlng As Integer, i As Integer
    Dim rval As String
    Dim rpark As String
    Dim strEnvoyer As String
    Dim OutMail As Object
    Dim MonOutlook As Object
    Dim MonMessage As Object
    Dim strBody As String
    Dim strSignature As String
 
    Set MonOutlook = CreateObject("Outlook.Application")
    Set MonMessage = MonOutlook.CreateItem(0)
    strEnvoyer = "xxxxxxxx" ' Mailto: To
    MonMessage.To = strEnvoyer
    MonMessage.Subject = "Emergency exit not controlled " & Date
    dlng = Range("C65536").End(xlUp).Row
 
    For i = 27 To dlng
        If Me.ComboBox13 = "" Then Exit Sub
        date1 = Cells(i, 2).Value
        date2 = Date
        Duree = DateDiff("d", date1, date2)
 
        If Duree > 3 And Cells(i, 4).Value = Me.ComboBox13.Value Then
            Cells(i, 9).Value = Duree
            rval = Cells(i, 5).Value
            rpark = Cells(i, 4).Value
 
            strSignature = MonMessage.HTMLBody
            strBody = strBody & "<table style=width:100%; cellpadding=20; cellspacing=1; border=1>"
            strBody = strBody & "<tr>"
            strBody = strBody & "<th>Parking</th>"
            strBody = strBody & "<th>Emergency exit not controlled</th>"
            strBody = strBody & "<th>Delay</th>"
            strBody = strBody & "</tr>"
            strBody = strBody & "<tr>"
            strBody = strBody & "<td align=center valign=middle>" & Replace(rpark, vbCrLf, "</td>")
            strBody = strBody & "<td align=center valign=middle>" & Replace(rval, vbCrLf, "</td>")
            strBody = strBody & "<td align=center valign=middle>" & Replace(Duree, vbCrLf, "</td>")
            strBody = strBody & "</tr>"
            strBody = strBody & "</table>"
       Else
         If Duree < 2 And Me.ComboBox13.Value <> Cells(i, 4).Value Then
            GoTo demande1
         End If
 
       End If
 
    Next i
 
    strBody = strBody & "<p style font-family=courier; font-size=24; style=color:#090909>" & "<b>" & "Best regards</b></p>"
    strBody = strBody & "<p style font-family=courier; font-size=24; style=color:#090909>" & UCase(Environ("USERNAME"))
 
    MonMessage.HTMLBody = strBody
    ThisWorkbook.Save
    MonMessage.Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
    MonMessage.send
    Set MonOutlook = Nothing
 
 
demande1:
    'Cherche la première ligne vide
    lig = Range("B" & Rows.Count).End(xlUp).Row + 1
 
    'Copie le parking choisi dans la colonne D
    Cells(lig, 4) = Me.ComboBox13
    If Me.ComboBox13 <> "" Then
        'Met la date et l'heure dans les colonne B et C
        Me.TextBox55 = Date: Cells(lig, 2) = Me.TextBox55
        Me.TextBox103 = Time: Cells(lig, 3) = Me.TextBox103
    Else
        Exit Sub
    End If
 
    'Description de la sortie de secours
    EMERGENCY_EXIT = InputBox("Please enter the name of the emergency exit ", "Emergency exit ?")
    Me.TextBox57 = EMERGENCY_EXIT: Cells(lig, 5) = EMERGENCY_EXIT
    If Me.TextBox57 <> "" Then
        Cells(lig, 6) = "True"
    Else
        Cells(lig, 6) = "False"
    End If
 
    'CHECKED BY
    CHECKED_BY = InputBox("Please enter the name of the person who made the control ?")
    Me.TextBox60 = CHECKED_BY: Cells(lig, 7) = CHECKED_BY
 
    'Commentaires
    Comments = InputBox("please enter your comments ?")
    Me.TextBox59 = Comments: Cells(lig, 8) = Comments
End Sub

Alors, met tout ce qui concerne le message dans ta condition vraie.

Code:

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
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
Private Sub ComboBox13_Change()
Dim date1 As Date, date2 As Date, Duree As Integer, dlng As Integer, i As Integer
    Dim rval As String
    Dim rpark As String
    Dim strEnvoyer As String
    Dim OutMail As Object
    Dim MonOutlook As Object
    Dim MonMessage As Object
    Dim strBody As String
    Dim strSignature As String
 
    Set MonOutlook = CreateObject("Outlook.Application")
    Set MonMessage = MonOutlook.CreateItem(0)
    strEnvoyer = "xxxxxxxx" ' Mailto: To
    MonMessage.To = strEnvoyer
    MonMessage.Subject = "Emergency exit not controlled " & Date
    dlng = Range("C65536").End(xlUp).Row
 
    For i = 27 To dlng
        If Me.ComboBox13 = "" Then Exit Sub
        date1 = Cells(i, 2).Value
        date2 = Date
        Duree = DateDiff("d", date1, date2)
 
        If Duree > 3 And Cells(i, 4).Value = Me.ComboBox13.Value Then
            Cells(i, 9).Value = Duree
            rval = Cells(i, 5).Value
            rpark = Cells(i, 4).Value
 
            strSignature = MonMessage.HTMLBody
            strBody = strBody & "<table style=width:100%; cellpadding=20; cellspacing=1; border=1>"
            strBody = strBody & "<tr>"
            strBody = strBody & "<th>Parking</th>"
            strBody = strBody & "<th>Emergency exit not controlled</th>"
            strBody = strBody & "<th>Delay</th>"
            strBody = strBody & "</tr>"
            strBody = strBody & "<tr>"
            strBody = strBody & "<td align=center valign=middle>" & Replace(rpark, vbCrLf, "</td>")
            strBody = strBody & "<td align=center valign=middle>" & Replace(rval, vbCrLf, "</td>")
            strBody = strBody & "<td align=center valign=middle>" & Replace(Duree, vbCrLf, "</td>")
            strBody = strBody & "</tr>"
            strBody = strBody & "</table>"
            strBody = strBody & "<p style font-family=courier; font-size=24; style=color:#090909>" & "<b>" & "Best regards</b></p>"
            strBody = strBody & "<p style font-family=courier; font-size=24; style=color:#090909>" & UCase(Environ("USERNAME"))
 
            MonMessage.HTMLBody = strBody
            ThisWorkbook.Save
            MonMessage.Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
            MonMessage.send       Else
 
            If Duree < 2 And Me.ComboBox13.Value <> Cells(i, 4).Value Then
               GoTo demande1
            End If
 
       End If
 
 
    Next i
 
 
    Set MonOutlook = Nothing
 
 
demande1:
    'Cherche la première ligne vide
    lig = Range("B" & Rows.Count).End(xlUp).Row + 1
 
    'Copie le parking choisi dans la colonne D
    Cells(lig, 4) = Me.ComboBox13
    If Me.ComboBox13 <> "" Then
        'Met la date et l'heure dans les colonne B et C
        Me.TextBox55 = Date: Cells(lig, 2) = Me.TextBox55
        Me.TextBox103 = Time: Cells(lig, 3) = Me.TextBox103
'    Else
'        Exit Sub  'pas nécessaire - déjà fait plus haut
    End If
 
    'Description de la sortie de secours
    EMERGENCY_EXIT = InputBox("Please enter the name of the emergency exit ", "Emergency exit ?")
    Me.TextBox57 = EMERGENCY_EXIT: Cells(lig, 5) = EMERGENCY_EXIT
    If Me.TextBox57 <> "" Then
        Cells(lig, 6) = "True"
    Else
        Cells(lig, 6) = "False"
    End If
 
    'CHECKED BY
    CHECKED_BY = InputBox("Please enter the name of the person who made the control ?")
    Me.TextBox60 = CHECKED_BY: Cells(lig, 7) = CHECKED_BY
 
    'Commentaires
    Comments = InputBox("please enter your comments ?")
    Me.TextBox59 = Comments: Cells(lig, 8) = Comments
End Sub

marche pas, je reçois cette fois-ci l'erreur sur MonMessage.send

merci pour ton aide.

Je pense qu'il faut juste un ptit réglage au niveau de mon bouton next afin réinitialiser ma combobox car avec ce code-ci cela fonctionne pour le 1er essai.

Dès que je la vide et recharge une valeur cela ne marche plus.

Code:

Code:

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
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
Private Sub ComboBox13_Change()
Dim date1 As Date, date2 As Date, Duree As Integer, dlng As Integer, i As Integer
    Dim rval As String
    Dim rpark As String
    Dim strEnvoyer As String
    Dim OutMail As Object
    Dim MonOutlook As Object
    Dim MonMessage As Object
    Dim strBody As String
    Dim strSignature As String
 
    Set MonOutlook = CreateObject("Outlook.Application")
    Set MonMessage = MonOutlook.CreateItem(0)
    strEnvoyer = "xxxxxxxx" ' Mailto: To
    MonMessage.To = strEnvoyer
    MonMessage.Subject = "Emergency exit not controlled " & Date
    dlng = Range("C65536").End(xlUp).Row
 
    For i = 27 To dlng
        If Me.ComboBox13 = "" Then Exit Sub
        date1 = Cells(i, 2).Value
        date2 = Date
        Duree = DateDiff("d", date1, date2)
 
        If Duree > 3 And Cells(i, 4).Value = Me.ComboBox13.Value Then
            Cells(i, 9).Value = Duree
            rval = Cells(i, 5).Value
            rpark = Cells(i, 4).Value
 
            strSignature = MonMessage.HTMLBody
            strBody = strBody & "<table style=width:100%; cellpadding=20; cellspacing=1; border=1>"
            strBody = strBody & "<tr>"
            strBody = strBody & "<th>Parking</th>"
            strBody = strBody & "<th>Emergency exit not controlled</th>"
            strBody = strBody & "<th>Delay</th>"
            strBody = strBody & "</tr>"
            strBody = strBody & "<tr>"
            strBody = strBody & "<td align=center valign=middle>" & Replace(rpark, vbCrLf, "</td>")
            strBody = strBody & "<td align=center valign=middle>" & Replace(rval, vbCrLf, "</td>")
            strBody = strBody & "<td align=center valign=middle>" & Replace(Duree, vbCrLf, "</td>")
            strBody = strBody & "</tr>"
            strBody = strBody & "</table>"
       Else
         If Duree < 2 And Me.ComboBox13.Value <> Cells(i, 4).Value Then
            GoTo demande1
         End If
 
       End If
 
    Next i
 
    strBody = strBody & "<p style font-family=courier; font-size=24; style=color:#090909>" & "<b>" & "Best regards</b></p>"
    strBody = strBody & "<p style font-family=courier; font-size=24; style=color:#090909>" & UCase(Environ("USERNAME"))
 
    MonMessage.HTMLBody = strBody
    ThisWorkbook.Save
    MonMessage.Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
    MonMessage.send
    Set MonOutlook = Nothing
 
 
demande1:
    'Cherche la première ligne vide
    lig = Range("B" & Rows.Count).End(xlUp).Row + 1
 
    'Copie le parking choisi dans la colonne D
    Cells(lig, 4) = Me.ComboBox13
    If Me.ComboBox13 <> "" Then
        'Met la date et l'heure dans les colonne B et C
        Me.TextBox55 = Date: Cells(lig, 2) = Me.TextBox55
        Me.TextBox103 = Time: Cells(lig, 3) = Me.TextBox103
    Else
        Exit Sub
    End If
 
    'Description de la sortie de secours
    EMERGENCY_EXIT = InputBox("Please enter the name of the emergency exit ", "Emergency exit ?")
    Me.TextBox57 = EMERGENCY_EXIT: Cells(lig, 5) = EMERGENCY_EXIT
    If Me.TextBox57 <> "" Then
        Cells(lig, 6) = "True"
    Else
        Cells(lig, 6) = "False"
    End If
 
    'CHECKED BY
    CHECKED_BY = InputBox("Please enter the name of the person who made the control ?")
    Me.TextBox60 = CHECKED_BY: Cells(lig, 7) = CHECKED_BY
 
    'Commentaires
    Comments = InputBox("please enter your comments ?")
    Me.TextBox59 = Comments: Cells(lig, 8) = Comments
End Sub

23/06/2016, 15h48
parmi

Citation:

Envoyé par vincent007

marche pas, je reçois cette fois-ci l'erreur sur MonMessage.send

merci pour ton aide.

Enlève le Else à la fin de la ligne (oubli de ma part en copiant)

Code:

MonMessage.send ' Else

oui çà été corrigé, entre temps j'ai utilisé l'autre code voir message précédent.

comprend pas ce qui cloche.

Code:

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
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
Dim date1 As Date, date2 As Date, Duree As Integer, dlng As Integer, i As Integer
    Dim rval As String
    Dim rpark As String
    Dim strEnvoyer As String
    Dim OutMail As Object
    Dim MonOutlook As Object
    Dim MonMessage As Object
    Dim strBody As String
    Dim strSignature As String
 
    Set MonOutlook = CreateObject("Outlook.Application")
    Set MonMessage = MonOutlook.CreateItem(0)
    strEnvoyer = "vrousseau@interparking.com" ' Mailto: To
    MonMessage.To = strEnvoyer
    MonMessage.Subject = "Emergency exit not controlled " & Date
    dlng = Range("C65536").End(xlUp).Row
 
    For i = 27 To dlng
 
        date1 = Cells(i, 2).Value
        date2 = Date
        Duree = DateDiff("d", date1, date2)
 
        If Duree > 3 And Cells(i, 4).Value = Me.ComboBox13.Value Then
            Cells(i, 9).Value = Duree
            rval = Cells(i, 5).Value
            rpark = Cells(i, 4).Value
 
            strSignature = MonMessage.HTMLBody
            strBody = strBody & "<table style=width:100%; cellpadding=20; cellspacing=1; border=1>"
            strBody = strBody & "<tr>"
            strBody = strBody & "<th>Parking</th>"
            strBody = strBody & "<th>Emergency exit not controlled</th>"
            strBody = strBody & "<th>Delay</th>"
            strBody = strBody & "</tr>"
            strBody = strBody & "<tr>"
            strBody = strBody & "<td align=center valign=middle>" & Replace(rpark, vbCrLf, "</td>")
            strBody = strBody & "<td align=center valign=middle>" & Replace(rval, vbCrLf, "</td>")
            strBody = strBody & "<td align=center valign=middle>" & Replace(Duree, vbCrLf, "</td>")
            strBody = strBody & "</tr>"
            strBody = strBody & "</table>"
       Else
         If Duree < 2 And Me.ComboBox13.Value <> Cells(i, 4).Value Then
            GoTo demande1
         End If
 
       End If
 
    Next i
 
    strBody = strBody & "<p style font-family=courier; font-size=24; style=color:#090909>" & "<b>" & "Best regards</b></p>"
    strBody = strBody & "<p style font-family=courier; font-size=24; style=color:#090909>" & UCase(Environ("USERNAME"))
 
    MonMessage.HTMLBody = strBody
    ThisWorkbook.Save
    MonMessage.Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
    MonMessage.send
    Set MonOutlook = Nothing
 
 
demande1:
    'Cherche la première ligne vide
    lig = Range("B" & Rows.Count).End(xlUp).Row + 1
 
    'Copie le parking choisi dans la colonne D
    Cells(lig, 4) = Me.ComboBox13
    If Me.ComboBox13 <> "" Then
        'Met la date et l'heure dans les colonne B et C
        Me.TextBox55 = Date: Cells(lig, 2) = Me.TextBox55
        Me.TextBox103 = Time: Cells(lig, 3) = Me.TextBox103
    Else
        Exit Sub
    End If
 
    'Description de la sortie de secours
    EMERGENCY_EXIT = InputBox("Please enter the name of the emergency exit ", "Emergency exit ?")
    Me.TextBox57 = EMERGENCY_EXIT: Cells(lig, 5) = EMERGENCY_EXIT
    If Me.TextBox57 <> "" Then
        Cells(lig, 6) = "True"
    Else
        Cells(lig, 6) = "False"
    End If
 
    'CHECKED BY
    CHECKED_BY = InputBox("Please enter the name of the person who made the control ?")
    Me.TextBox60 = CHECKED_BY: Cells(lig, 7) = CHECKED_BY
 
    'Commentaires
    Comments = InputBox("please enter your comments ?")
    Me.TextBox59 = Comments: Cells(lig, 8) = Comments

Change le .Send par .Display

Tu mets ceci en dehors de ta boucle et conditions, alors si le code ne trouve rien, il va tout de même passer par ces lignes...
Code:

1 2 3 4 5 6 7 strBody = strBody & "" & "" & "Best regards" strBody = strBody & "" & UCase(Environ("USERNAME")) MonMessage.HTMLBody = strBody ThisWorkbook.Save MonMessage.Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name MonMessage.send
S'il y a une erreur, donne le numéro et la description ainsi que la ligne en erreur.

23/06/2016, 16h31
vincent007

Ce code était déjà en dehors de la boucle et condition.

J'ai changé par .Display, cela fonctionne la 1er fois ensuite dès que je vide ma combobox et que je recommence le mail n'est pas envoyé il passe directement à la demande1

Bien à toi

J eviens de capter un truc, cela doit venir du format date

Dans mon tableau j'ai ceci en colonne date, 2 format différents.

11/06/2016
11/06/2016
20/06/2016
16/06/2016
6/23/2016
6/23/2016
6/23/2016
23/06/2016, 16h41
parmi

Il y en a aussi en format Standard...

Voir 40 message(s) de cette discussion en une page