Sheets("Courrier").Select
Sheets("Courrier").Copy After:=Sheets(4)
Range("C18:D18").Select
ActiveCell.FormulaR1C1 = "='A envoyer'!R[-12]C[-1]"
Sheets("A envoyer").Select
Sheets("Courrier(2)").Select
Sheets("Courrier(2)").Name = Sheets("A envoyer").Range("B6")
Range("A7").Select
Sheets("Courrier").Select
Sheets("Courrier").Copy After:=Sheets(4)
Range("C18:D18").Select
ActiveCell.FormulaR1C1 = "='A envoyer'!R[-11]C[-1]"
Sheets("A envoyer").Select
Sheets("Courrier(2)").Select
Sheets("Courrier(2)").Name = Sheets("A envoyer").Range("B7")
Range("A7").Select
ActiveCell.FormulaR1C1 = "='A envoyer'!R[-12]C[-1]"
Private Sub CommandButton1_Click()
Dim Lg As Long ' Variable définissant le n° de ligne sur la feuille Recap
Range("B8:B65536").ClearContents ' Vide les cellules en colonne B, Feuille Recap
Lg = 8 ' Définit la ligne de départ pour inserion des références en colonne B, Feuille Recap
' Lit en boucle les n° de semaines sur la feuille Adresse
' La lecture commence en ligne 4 et s'arrête sur la dernière cellule remplie dans la colonne A
For Each cel In Sheets("Adresses").Range("A4:A" & Sheets("Adresses").Range("A65536").End(xlUp).Row)
' Si le N° de semaine correspond à la cellule B5
If cel.Value = Range("B5").Value Then
' On ajoute la référence à la ligne
Cells(Lg, 2) = Sheets("Adresses").Cells(cel.Row, 2)
' et on fixe la position de la ligne suivante
Lg = Lg + 1
End If
Next
' Appel de la macro de mise à jour/création des feuilles
Courriers
End Sub
Sub Courriers()
' RefCourrier contient la référence du courrier
' ListCourrier contient les noms des feuilles déjà présentes dans le classeur
Dim RefCourrier As String, ListCourriers As String
' LRef contient le n° de ligne de la référence trouvée
Dim LRef As Long
' Trouve détermine si une feuille est existante ou pas
Dim Trouve As Boolean
Application.DisplayAlerts = False ' Empêche l'affichage des messages sytème
ListCourriers = ""
' Balayage des feuilles existantes dans le classeur
For Each sh In Sheets
' Si la feuille n'est pas dans la liste, on l'y ajoute (avec une virgule de séparation
If InStr(ListCourriers, sh.Name) = 0 Then ListCourriers = ListCourriers & sh.Name & ","
Next
' Balayage de la colonne B, lignes 8 à dernière ligne remplie
For Each cel In Range("B8:B" & Range("B65536").End(xlUp).Row)
RefCourrier = cel.Value ' Affecte la valeur de la cellule lue à la variable RefCourrier
If InStr(ListCourriers, RefCourrier) > 0 Then
' Si RefCourrier est dans la liste
Trouve = True ' Trouve = vrai
' Affiche la boîte de message Courrier existant
rep = MsgBox("Le courrier " & RefCourrier & " existe déjà !" & vbCrLf & "Voulez-vous le remplacer ?", vbYesNo + vbQuestion, "COURRIER EXISTANT")
Else
Trouve = False ' Sinon Trouve = faux
End If
If rep = vbNo Then GoTo Suite ' Si on a répondu Non à la boîte de dialogue, on boucle à la cellule suivante
' Si on a répondu Oui
' Et si Trouve = vrai, alors on supprime la feuille existante
If Trouve = True Then Sheets(RefCourrier).Delete
' Copie et place en dernière position la feuille Courrier Type
Sheets("Courrier Type").Copy After:=Sheets(Sheets.Count)
' Affiche la feuille Récap
Sheets("Recap").Activate
' Toutes les actions suivantes se font sur la feuille qui vient d'être copiée
With Sheets(Sheets.Count)
' Renomme la feuille
.Name = RefCourrier
' Cherche la référence dans la colonne B de la feuille Adresses
Set Ref = Sheets("Adresses").Range("B:B").Find(RefCourrier, LookIn:=xlValues, lookat:=xlWhole)
' Si la référence est trouvée
If Not Ref Is Nothing Then
' On recupère son n° de ligne
LRef = Ref.Row
' Et on recopie les données dans les cellules de la feuille qui vient d'être copiée
.Range("C18") = Sheets("Adresses").Cells(LRef, 2)
.Range("G7") = Sheets("Adresses").Cells(LRef, 3)
.Range("G8") = Sheets("Adresses").Cells(LRef, 4)
.Range("G9") = Sheets("Adresses").Cells(LRef, 5)
.Range("G10") = Sheets("Adresses").Cells(LRef, 6)
.Range("G11") = Sheets("Adresses").Cells(LRef, 7) & " " & Sheets("Adresses").Cells(LRef, 8)
End If
End With
Suite:
Next cel
Application.DisplayAlerts = True ' Rétablit l'affichage des messages sytème
End Sub
Sheets("Courrier Type").Copy After:=Sheets(Sheets.Count)
Sub Tst_PdfCreator()
' Dim objMessage As CDO.Message
Dim jobPDF As Object
Dim sNomPDF As String
Dim sCheminPDF As String
' Dim Chemin As String
'Enregistrement du classeur (instruction désactivée)
' ActiveWorkbook.Save
' Chemin = ThisWorkbook.Path & "\Courriers Bailleurs\"
'préfixe = Sheets("Infos").Range("B1") & ("-Courrier Bailleur-IP Natif 2010-") & Sheets("Infos").Range("D1").Value
' à adapter en fonction des noms de tes onglets
Sheets(Array("Courrier Bailleur")).Copy
'Sheets (Array(Sheets("Infos").Range("B1").Copy
sNomPDF = "Essai.pdf"
sCheminPDF = ActiveWorkbook.Path & Application.PathSeparator
If IsEmpty(ActiveSheet.UsedRange) Then Exit Sub
Set jobPDF = CreateObject("PDFCreator.clsPDFCreator")
With jobPDF
If .cStart("/NoProcessingAtStartup") = False Then
MsgBox "Initialisation de PDFCreator impossible", vbCritical + vbOKOnly, "PDFCreator"
Exit Sub
End If
.cOption("UseAutosave") = 1
.cOption("UseAutosaveDirectory") = 1
.cOption("AutosaveDirectory") = sCheminPDF
.cOption("AutosaveFilename") = sNomPDF
'0=PDF, 1=Png, 2=jpg, 3=bmp, 4=pcx, 5=tif, 6=ps, 7=eps, 8=txt
.cOption("AutosaveFormat") = 0
.cClearCache
End With
ActiveSheet.PrintOut copies:=1, ActivePrinter:="PDFCreator"
'Fichier dans la file d'attente
Do Until jobPDF.cCountOfPrintjobs = 1
DoEvents
Loop
jobPDF.cPrinterStop = False
'Attendre que la file d'attente soit vide
Do Until jobPDF.cCountOfPrintjobs = 0
DoEvents
Loop
jobPDF.cClose
Set jobPDF = Nothing
' Set objMessage = CreateObject("CDO.Message")
' With objMessage
' .Subject = "Essai"
' .From = "xxxxx@wanadoo.fr"
' .To = "yyyyy@wanadoo.fr"
' .TextBody = "Texte dans le corps de message"
' .AddAttachment sCheminPDF & sNomPDF
' .Send
' End With
' Set objMessage = Nothing
End Sub
Bonjour à tous,
Merci pour ces explications, je vais voir ce que ça donne pour l'adapter, ca devrait le faire !! Merci
Par contre, lorsque je supprime les onglets créés, j'ai ensuite une ereur sur cette ligne :
HTML:Sheets("Courrier Type").Copy After:=Sheets(Sheets.Count)
Je souhaiterai ensuite enregistrer en .pdf chaque courrier, pour une autre application, j'avais utilisé le code suivant (que j'avais également trouvé sur ce forum,) et qui fonctionne bien. par contre dire d'enregistrer chaque nouvel onglet créé dans un PDF différent ???
HTML:Sub Tst_PdfCreator() ' Dim objMessage As CDO.Message Dim jobPDF As Object Dim sNomPDF As String Dim sCheminPDF As String ' Dim Chemin As String 'Enregistrement du classeur (instruction désactivée) ' ActiveWorkbook.Save ' Chemin = ThisWorkbook.Path & "\Courriers Bailleurs\" 'préfixe = Sheets("Infos").Range("B1") & ("-Courrier Bailleur-IP Natif 2010-") & Sheets("Infos").Range("D1").Value ' à adapter en fonction des noms de tes onglets Sheets(Array("Courrier Bailleur")).Copy 'Sheets (Array(Sheets("Infos").Range("B1").Copy sNomPDF = "Essai.pdf" sCheminPDF = ActiveWorkbook.Path & Application.PathSeparator If IsEmpty(ActiveSheet.UsedRange) Then Exit Sub Set jobPDF = CreateObject("PDFCreator.clsPDFCreator") With jobPDF If .cStart("/NoProcessingAtStartup") = False Then MsgBox "Initialisation de PDFCreator impossible", vbCritical + vbOKOnly, "PDFCreator" Exit Sub End If .cOption("UseAutosave") = 1 .cOption("UseAutosaveDirectory") = 1 .cOption("AutosaveDirectory") = sCheminPDF .cOption("AutosaveFilename") = sNomPDF '0=PDF, 1=Png, 2=jpg, 3=bmp, 4=pcx, 5=tif, 6=ps, 7=eps, 8=txt .cOption("AutosaveFormat") = 0 .cClearCache End With ActiveSheet.PrintOut copies:=1, ActivePrinter:="PDFCreator" 'Fichier dans la file d'attente Do Until jobPDF.cCountOfPrintjobs = 1 DoEvents Loop jobPDF.cPrinterStop = False 'Attendre que la file d'attente soit vide Do Until jobPDF.cCountOfPrintjobs = 0 DoEvents Loop jobPDF.cClose Set jobPDF = Nothing ' Set objMessage = CreateObject("CDO.Message") ' With objMessage ' .Subject = "Essai" ' .From = "xxxxx@wanadoo.fr" ' .To = "yyyyy@wanadoo.fr" ' .TextBody = "Texte dans le corps de message" ' .AddAttachment sCheminPDF & sNomPDF ' .Send ' End With ' Set objMessage = Nothing End Sub