Problème code VBA pour imprimer plusieurs onglets
Bonjour,
je cherche une astuce pour imprimer plusieurs onglet en PDF suivant une sélection de cellule et ensuite l'envoyer par mail.
le code ci dessous a bien fonctionné les 2 premières fois, mais depuis il me met une erreur de débogage sur la ligne sheets (array,...
suivant la valeur de la cellule.
je cherche mon erreur et je ne trouve pas, si une personne la vois cette erreur, cela m aiderais beaucoup
cordialement
Private Sub EnvoyerRDCNEWS_Click()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim S As Shape
Dim sNomFic As String, sRep As String, WshShell As Object
Dim dossierimp As Integer
dossierimp = Sheets("page bouton").Cells(7, 34).Value
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set WshShell = CreateObject("WScript.Shell")
sRep = WshShell.SpecialFolders("C:\GESTION RST\RDC\")
Set WshShell = Nothing
sNomFic = "RDC" & " " & "de" & " " & Worksheets("Fiche Renseignement").Range("E15") & " " & Worksheets("Fiche Renseignement").Range("C18") & " " & Worksheets("Fiche Renseignement").Range("G18") & " " & "Client_N°" & " " & Worksheets("Fiche Renseignement").Range("B15") & ".pdf"
destinataires = ("relevechantier@lavance.com")
responsabletravaux = (Worksheets("Fiche Renseignement").Range("E10").Value)
If dossierimp = 1 Then
Sheets(Array("Fiche Renseignement", "MP", "Photos", "Plan levage decharg", "Permis feu")).Select
ElseIf dossierimp = 3 Then
Sheets(Array("Fiche Renseignement", "HP", "Photos", "Plan levage decharg", "Permis feu")).Select
ElseIf dossierimp = 4 Then
Sheets(Array("Fiche Renseignement", "MP", "HP", "Photos", "Plan levage decharg", "Permis feu")).Select
ElseIf dossierimp = 9 Then
Sheets(Array("Fiche Renseignement", "PL", "Photos", "Plan levage decharg", "Permis feu")).Select
ElseIf dossierimp = 10 Then
Sheets(Array("Fiche Renseignement", "MP", "PL", "Photos", "Plan levage decharg", "Permis feu")).Select
ElseIf dossierimp = 12 Then
Sheets(Array("Fiche Renseignement", "HP", "PL", "Photos", "Plan levage decharg", "Permis feu")).Select
ElseIf dossierimp = 13 Then
Sheets(Array("Fiche Renseignement", "MP", "HP", "PL", "Photos", "Plan levage decharg", "Permis feu")).Select
ElseIf dossierimp = 17 Then
Sheets(Array("Fiche Renseignement", "Péripheriques", "Photos", "Plan levage decharg", "Permis feu")).Select
ElseIf dossierimp = 18 Then
Sheets(Array("Fiche Renseignement", "MP", "Péripheriques", "Photos ", "Plan levage decharg", "Permis feu")).Select
ElseIf dossierimp = 20 Then
Sheets(Array("Fiche Renseignement", "HP", "Péripheriques", "Photos ", "Plan levage decharg", "Permis feu")).Select
ElseIf dossierimp = 21 Then
Sheets(Array("Fiche Renseignement", "MP", "HP", "Péripheriques", "Photos", "Plan levage decharg", "Permis feu")).Select
ElseIf dossierimp = 26 Then
Sheets(Array("Fiche Renseignement", "PL", "Péripheriques", "Photos ", "Plan levage decharg", "Permis feu")).Select
ElseIf dossierimp = 27 Then
Sheets(Array("Fiche Renseignement", "MP", "PL", "Péripheriques", "Photos", "Plan levage decharg", "Permis feu")).Select
ElseIf dossierimp = 29 Then
Sheets(Array("Fiche Renseignement", "HP", "PL", "Péripheriques", "Photos", "Plan levage decharg", "Permis feu")).Select
ElseIf dossierimp = 30 Then
Sheets(Array("Fiche Renseignement", "MP", "HP", "Péripheriques", "PL", "Photos ", "Plan levage decharg", "Permis feu")).Select
End If
ChDir "C:\GESTION RST\RDC\"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sRep & "C:\GESTION RST\RDC\" & sNomFic, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Set OutApp = CreateObject("outlook.application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = destinataires
.Cc = responsabletravaux
.Attachments.Add ("C:\GESTION RST\RDC\" & sNomFic)
.Subject = "RDC" & " " & "de" & " " & Worksheets("Fiche Renseignement").Range("E14") & " " & "à" & " " & Worksheets("Fiche Renseignement").Range("C17") & " " & Worksheets("Fiche Renseignement").Range("G17") & " " & "Client_N°" & " " & Worksheets("Fiche Renseignement").Range("B14")
.body = "Bonjour," & vbLf & vbLf & "Vous trouverez en pièce jointe le RDC du client cité en Objet." & vbLf & vbLf & " Je reste à votre disposition pour tous renseignements complémentaires." & vbLf & vbLf & Worksheets("Fiche Renseignement").Range("E8") & vbLf & "Responsable Travaux LAVANCE" & vbLf & "Tél: 0" & Worksheets("Fiche Renseignement").Range("E9") & vbLf & "Mail: " & Worksheets("Fiche Renseignement").Range("E10")
.Display
.Display
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Kill (sRep & "C:\GESTION RST\RDC\" & sNomFic)
End Sub
59xxx - Offre Commerciale.xlsx
(240.63 Kio) Téléchargé 3 fois
J'ajoute ma demande car j'ai un problème similaire;
Points à prendre en compte:
Fichier en partage sur réseau, il est copié à chaque début de projet par plusieurs personnes puis renommé. Les champs internes au fichier sont ensuite renseignés.
Il faut donc que la macro suive lors de la copie des fichiers
Demande:
Extraire les 3 onglets P GARDE + Offre FR et Fiche prix à l'aide d'un bouton (macro).
L'extraction laissera un PDF à coté du XLS et ouvrira la visionneuse PDF
J'ai tenté la macro suivante mais sans grand succès notamment les macros se perdent à chaque copie du fichier:
Sub CreerPDF()
Dim sRep As String
Dim sFilename As String
Sheets(Array("P GARDE", "Offre FR", "Fiche prix")).Select
sRep = ThisWorkbook.Path
sFilename = ThisWorkbook.Name
sFilename = Left(sFilename, InStr(1, sFilename, ".")) & "pdf"
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=sRep & sFilename, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End Sub
Je pense que la base est bonne j'aimerais avoir un nom de fichier PDF identique à celui du fichier XLS (il changera à la copie du fichier XLS au début du projet).
Merci de m'aider. Pour plus d'infos n'hésitez pas!