NomDeLaFeuille = Range("C15").Value
If Range("D15").Value = "OK"
Then
ThisWorkbook.Sheets(NomDeLaFeuille).Copy
ActiveWorkbook.SaveAs ("C:\Documents and Settings\user\Mes documents\" & NomDeLaFeuille)
ActiveWorkbook.Close
ZoneSelectionNomDesFeuillesACopier = Range("C15:C25").Value [COLOR="Green"]'Je sais que je dois passer par une sélection de zone mais je ne sais pas comment l'implementer[/COLOR]
NomDeLaFeuille = [COLOR="Red"]Range("C15").Value[/COLOR] [COLOR="Green"]'C'est là ou je sais pas comment on peut sélectionner plusieurs feuilles pour créer des classeurs multiples.[/COLOR]
If Range("D15").Value = "OK" [COLOR="Green"] 'a coté de chaque feuille choisi, il devra valider OK[/COLOR]
And If Not Range ("C15").Value = "" [COLOR="Green"]'afin de ne choisir dans la zone que les cellules ou un nom apparaît[/COLOR]
Then
ThisWorkbook.Sheets(NomDeLaFeuille).Copy
ActiveWorkbook.SaveAs ("C:\Documents and Settings\user\Mes documents\" & NomDeLaFeuille)
ActiveWorkbook.Close
Do While Not IsEmpty("C15:C25")
NomDeLaFeuille = Range("C15").Value
If Range("D15").Value = "OK" And Not Range("C15").Value = "" Then
Then
ThisWorkbook.Sheets(NomDeLaFeuille).Copy
ActiveWorkbook.SaveAs ("C:\Documents and Settings\user\Mes documents\" & NomDeLaFeuille)
ActiveWorkbook.Close
End If
Loop
Sub EnvoiMail()
Dim NomDeLaFeuille(1 To 11) As Long
NomDeLaFeuille(1) = Range("C15").Value
NomDeLaFeuille(2) = Range("C16").Value
NomDeLaFeuille(3) = Range("C17").Value
NomDeLaFeuille(4) = Range("C18").Value
NomDeLaFeuille(5) = Range("C19").Value
NomDeLaFeuille(6) = Range("C20").Value
NomDeLaFeuille(7) = Range("C21").Value
NomDeLaFeuille(8) = Range("C22").Value
NomDeLaFeuille(9) = Range("C23").Value
NomDeLaFeuille(10) = Range("C24").Value
NomDeLaFeuille(11) = Range("C25").Value
If Not NomDeLaFeuille.Value = ""
Then
ThisWorkbook.Sheets(NomDeLaFeuille).Copy
ActiveWorkbook.SaveAs ("C:\Documents and Settings\user\Mes documents\" & NomDeLaFeuille)
ActiveWorkbook.Close
End if
Call Module3.SendMailCDO 'appel de la macro d'envoi
Kill "C:\Documents and Settings\user\Mes documents\" & NomDeLaFeuille & ".xls"
End Sub
Dim i As Integer
Dim NomDeLaFeuille As String
Dim NomDesClasseurs(1 To 11)
For i = 15 To 25
If Not IsEmpty(Range("C" & i)) And Range("D" & i) = "OK" Then
NomDeLaFeuille = Range("C" & i)
NomDesClasseurs(i - 15 + 1) = "C:\Documents and Settings\user\Mes documents\" & NomDeLaFeuille
ThisWorkbook.Sheets(NomDeLaFeuille).Copy
ActiveWorkbook.SaveAs ("C:\Documents and Settings\user\Mes documents\" & NomDeLaFeuille)
ActiveWorkbook.Close
Next i
For i = 1 To 11
Kill NomDesClasseurs(i)
Next
Dim i As Integer
Dim NomDeLaFeuille As String
Dim NomDesClasseurs(1 To 11)
For i = 15 To 25
If Not IsEmpty(Range("C" & i)) And Range("D" & i) = "OK" Then
NomDeLaFeuille = Range("C" & i)
NomDesClasseurs(i - 15 + 1) = "C:\Documents and Settings\user\Mes documents\" & NomDeLaFeuille
ThisWorkbook.Sheets(NomDeLaFeuille).Copy
ActiveWorkbook.SaveAs ("C:\Documents and Settings\user\Mes documents\" & NomDeLaFeuille)
ActiveWorkbook.Close
End If
Next i
For i = 1 To 11
Kill NomDesClasseurs(i)
Next
NomDesClasseurs(i - 15 + 1) = "C:\Documents and Settings\user\Mes documents\" & NomDeLaFeuille & ".xls"
Public Sub SendMailCDO(NomDesClasseurs)
For i = 1 To 11
If NomDesClasseurs(i) <> "" Then .AddAttachment NomDesClasseurs(i)
Next
For i = 15 To 25
If Not IsEmpty(Range("C" & i)) And Range("D" & i) = "OK" Then
NomDeLaFeuille = Range("C" & i)
NomDesClasseurs(i - 15 + 1) = "C:\Documents and Settings\user\Mes documents\" & NomDeLaFeuille
ThisWorkbook.Sheets(NomDeLaFeuille).Copy
ActiveWorkbook.SaveAs ("C:\Documents and Settings\user\Mes documents\" & NomDeLaFeuille)
ActiveWorkbook.Close
[COLOR=red][B]End If[/B][/COLOR]
Next i
[COLOR=red][B]Call SendMailCDO(NomDesClasseurs)[/B][/COLOR]
For i = 1 To 11
Kill NomDesClasseurs(i)
Next
For i = 1 To 11
If NomDesClasseurs(i) <> "" Then Kill NomDesClasseurs(i)
Next
Sub EnvoyerMail1()
Dim i As Integer
Dim NomDeLaFeuille As String
Dim NomDesClasseurs(1 To 11)
Dim ZonePJ As Range
Set ZonePJ = Range("C18:C28")
For i = 18 To 28
If Not IsEmpty(Range("C" & i)) And Range("D" & i) = "OK" Then
NomDeLaFeuille = Range("C" & i)
NomDesClasseurs(i - 18 + 1) = "C:\Documents and Settings\user\Mes documents\" & NomDeLaFeuille & ".xls"
ThisWorkbook.Sheets(NomDeLaFeuille).Copy
ActiveWorkbook.SaveAs ("C:\Documents and Settings\user\Mes documents\" & NomDeLaFeuille)
ActiveWorkbook.Close
End If
Next i
[COLOR="Red"]Range("C34").Value = NomDesClasseurs(i1);NomDesClasseurs(i2);NomDesClasseurs(i3);etc[/COLOR]
Dim D As String
Dim CC As String
Dim E As String
Dim S As String
Dim T As String
Dim pj As String
D = Range("C33").Value
CC = Range("C35").Value
E = Range("C15").Value
S = Range("C3").Value
T = Range("C6").Value & Chr(10) & Chr(10) & Range("C9").Value
[COLOR="Red"]pj = Range("C34").Value[/COLOR]
Dim Cdo_Message As New CDO.Message
Set Cdo_Message.Configuration = GetSMTPServerConfig()
With Cdo_Message
.To = D
.CC = CC
.From = E
.Subject = S
.TextBody = T
If Not IsMissing(pj) Then
.AddAttachment pj
End If
.send
End With
success = MsgBox(" envoyés avec succès !", vbInformation)
Exit Sub
SMTPSendMail_Err:
'Gestion des erreurs
tmp = MsgBox("Erreur lors de l'envoi de votre message." & Chr(10) & "Détails : " & Err.Description, vbCritical)
For i = 1 To 11
If NomDesClasseurs(i) <> "" Then Kill NomDesClasseurs(i)
Next
ZonePJ.ClearContents
End Sub
If Not IsMissing(pj1) Then
.AddAttachment pj1
End If
If Not IsMissing(pj2) Then
.AddAttachment pj2
End If
If Not IsMissing(pj3) Then
.AddAttachment pj3
End If
Et mettre pj = Range("C34").Value.Range("C34").Value = NomDesClasseurs(i1);NomDesClasseurs(i2);NomDesClasseurs(i3);etc
[COLOR="DarkSlateGray"]
Dim i As Integer
Dim j As Integer
Dim NomDeLaFeuille As String
Dim NomDesClasseurs(1 To 11)
Dim ZonePJ As Range
Set ZonePJ = Range("C18:D28")
For i = 18 To 28
If Not IsEmpty(Range("C" & i)) And Range("D" & i) = "OK" Then
NomDeLaFeuille = Range("C" & i)
NomDesClasseurs(i - 18 + 1) = "C:\Documents and Settings\user\Mes documents\" & NomDeLaFeuille & ".xls"
ThisWorkbook.Sheets(NomDeLaFeuille).Copy
ActiveWorkbook.SaveAs ("C:\Documents and Settings\user\Mes documents\" & NomDeLaFeuille)
ActiveWorkbook.Close
End If
Next i
[/COLOR]
[COLOR="Red"]For j = [C38] To [C48]
Do
Do While Not IsEmpty(Range("C" & j))
Range(j).Value = NomDesClasseurs
Exit Do
Loop
Loop Until i = 28
Next j[/COLOR]
[COLOR="DarkSlateGray"]
Dim D As String
Dim CC As String
Dim E As String
Dim S As String
Dim T As String[/COLOR]
[COLOR="red"]Dim pj As String <=== Devrait être As Integer ?[/COLOR]
[COLOR="DarkSlateGray"]D = Range("C33").Value
CC = Range("C35").Value
E = Range("C15").Value
S = Range("C3").Value
T = Range("C6").Value & Chr(10) & Chr(10) & Range("C9").Value[/COLOR]
[COLOR="Red"]pj = Range("C34").Value <== Devrai cibler la zone C38:C48 ?[/COLOR]
[COLOR="rgb(47, 79, 79)"]
Dim Cdo_Message As New CDO.Message
Set Cdo_Message.Configuration = GetSMTPServerConfig()
With Cdo_Message
.To = D
.CC = CC
.From = E
.Subject = S
.TextBody = T[/COLOR]
[COLOR="red"]If Not IsMissing(pj) Then <=== La loop doit être ici pour faire correspondre une pièce jointe pour chaque cellule de C38 à C48 en ne comptant pas les cellules vides
.AddAttachment pj
End If[/COLOR]
If Not IsMissing(pj1) Then
.AddAttachment pj1
End If
If Not IsMissing(pj2) Then
.AddAttachment pj2
End If
If Not IsMissing(pj3) Then
.AddAttachment pj3
End If