Boucle For dans Userform

**vincent007** · 22/06/2016, 15h39

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 VBA :

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
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

**parmi** · 22/06/2016, 17h05

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...

**vincent007** · 22/06/2016, 17h27

Bonjour,

Merci pour ton aide.

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

Nom : erreur.jpg
Affichages : 220
Taille : 464,4 Ko

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 :

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
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

**parmi** · 22/06/2016, 18h40

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

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
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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**vincent007** · 22/06/2016, 22h42

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 :

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
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 :

Sélectionner tout - Visualiser dans une fenêtre à part

strEnvoyer = "xxxxxx@xxxxx" ' Mailto: To

**parmi** · 22/06/2016, 22h57

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.

Boucle For dans Userform

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager