Problème macro enregistrement en PDF dans un dossier sur le bureau

Xtrm -  
 Xtrm -
Bonjour,

J'ai un soucis avec une macro qui fonctionnait sur mon ancien ordinateur mais ne fonctionne plus sur le nouveau.

J'ai deux listes déroulantes, une avec les régions et une avec les villes qui se met à jour en fonction de la région sélectionnée.

Le fait de définir région et ville donne une fiche avec des informations propres à la ville concernée

Je souhaite qu'une fois qu'on a sélectionné sa région sur l'onglet 1 (menu), la macro "imprime" en pdf la fiche pour chaque ville (onglet 2, fiche synthèse). Et les enregistre dans un fichier "Opération Flash" sur le bureau.

Voici ce que j'ai: 

Sub imprimer()

For i = 3 To 17

If Sheets("Menu").Range("K" & i).Value Like "HF*" Then
    Sheets("Menu").Select
    Range("C6").Copy
    Sheets("Fiche synthèse").Select
    Range("C3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Menu").Select
    Range("K" & i).Copy
    Sheets("Fiche synthèse").Select
    Range("C4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("c4").Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    "D:\" & "Environ(Username)" & "\Desktop\Opération Flash" & Range("c4") & " - " & Range("c6") & " - " & Range("g6") & " - " & Range("g3") & ".pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    Range("c4").Select
    Sheets("Menu").Select
    Range("c6").Select

    End If


J'ai mis en gras la partie qui pose problème. Je soupçonne que ce soit le chemin d'accès que j'ai mal indiqué.

Des solutions?

Merci pour votre aide

Configuration: Windows / Internet Explorer 11.0

1 réponse

  1.
    cs_Le Pivert Messages postés 8437 Statut Contributeur 731
     
    Bonjour,

    voir ceci pour enregistrer sur le Bureau, il faudra l'adapter à un PDF:

    https://forums.commentcamarche.net/forum/affich-35867658-excel-vba-enregistrer-fichier-bureau-renommer-par-rapport-a-une-cellule#1

    0
    1. Xtrm
       
      Merci cs_Le Pivert pour ta réponse.

      Je suis très novice en utilisation de macro, j'ai du mal à voir comment adapter cet exemple à mon fichier ?

      Merci d'avance.
      0
    2. cs_Le Pivert Messages postés 8437 Statut Contributeur 731
       
      Là tu fais une boucle, ce qui signifie que tu enregistres 14 fois. Il faut changer ta macro!

      Je ne vois pas le 
      Next i
      de ta boucle
      0
    3. Xtrm
       
      cs_Le Pivert, merci pour ta réponse.
      Oui cette partie est volontaire, je souhaite que la macro enregistre une fiche pour chaque ville de la région sélectionnée et la colonne K 3->17 donne la liste des villes en fonction de la région sélectionnée. En revanche, c'est la partie enregistrement qui n'est pas bonne j'ai l'impression
      0
    4. cs_Le Pivert Messages postés 8437 Statut Contributeur 731
       
      sans voir le classeur et ne sachant pas les valeurs que tu cherches dans ta boucle, j'ai juste remplacé le chemin du bureau et ajouter la valeur de i pour que les classeurs n'aient pas la même nom: 

      Option Explicit
Dim dossier As String
Dim bureau As String
Sub imprimer()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
cheminbureau
dossier = bureau & "\Opération Flash\"
For i = 3 To 17
If Sheets("Menu").Range("K" & i).Value Like "HF*" Then
Sheets("Menu").Select
Range("C6").Copy
Sheets("Fiche synthèse").Select
Range("C3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Menu").Select
Range("K" & i).Copy
Sheets("Fiche synthèse").Select
Range("C4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("c4").Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
dossier & Range("c4") & " - " & Range("c6") & " - " & Range("g6") & " - " & Range("g3") & "_i.pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Range("c4").Select
Sheets("Menu").Select
Range("c6").Select
End If
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Sub cheminbureau()
'https://excel-malin.com/codes-sources-vba/trouver-chemin-de-bureau/

    On Error GoTo TestErreur
    Dim cheminbureau As String
    
    cheminbureau = ObtenirCheminBureau()
    
    bureau = cheminbureau 'affiche le chemin vers le dossier Bureau
    Exit Sub
TestErreur:
    MsgBox "Une erreur s'est produite..."
End Sub
Public Function ObtenirCheminBureau() As String
'par: Excel-Malin.com ( https://excel-malin.com )

    On Error GoTo ObtenirCheminBureauError
    Dim cheminbureau As String
    cheminbureau = ""
    Dim oWSHShell As Object
    Set oWSHShell = CreateObject("WScript.Shell")
    
    cheminbureau = oWSHShell.SpecialFolders("Desktop")
    
    If (Not (oWSHShell Is Nothing)) Then Set oWSHShell = Nothing
    ObtenirCheminBureau = cheminbureau

    Exit Function
ObtenirCheminBureauError:
    If (Not (oWSHShell Is Nothing)) Then Set oWSHShell = Nothing
    ObtenirCheminBureau = ""
End Function


      Voilà

      @+ Le Pivert
      0
    5. Xtrm
       
      Merci Le Pivert d'avoir pris le temps de te pencher sur ma macro. J'ai toujours des codes erreurs, je vais essayer de trouver une alternative. Mais merci en tout cas
      0