Sauvegarder fichier Excel sous forme XPS Résolu

Question

Bonjour,

Comme tout le monde je débute depuis peut en VBA et je souhaiterais sauvegarder le contenu modifiable de mon fichier Excel sous forme XPS  dans l'emplacement suivant: "C:\Users\Med\Pictures\" et les renommer avec le contenu de la cellule ("E11") qui va comporter des chiffres allant de 1 à l'infini 


mon problème est le suivent: 
Lorsque je change 1 dans la cellule ("E11") par 2
le clic sur le bouton, liée à la Macro destiner à la sauvegarde, le Nom de mon fichier XPS reste fixe sur 1

Votre aide sera très précieuse pour moi 
Si j'arrive a changer le contenu de la cellule  ("E11") et changer le Nom de ma sauvegarde en XPS de 1 à l'infini.


La Macro que j'essaye d'utiliser est la suivante: 


Sub Enregistrer_sousTEST()
'
' Enregistrer_sousTEST Macro
'

'
    ActiveWindow.SmallScroll Down:=-12
    Rows("18:18").Select
    ActiveWindow.FreezePanes = False
    ActiveWindow.SmallScroll Down:=-15
    Range("A1:E81").Select
    ActiveWindow.SmallScroll Down:=-33
    Range("H34").Select
    ActiveWindow.SmallScroll Down:=-30
    Range("A1:E45").Select
    ActiveWindow.SmallScroll Down:=-9
    Range("E11").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("A3:E46").Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypeXPS, Filename:= _
        "C:\Users\Med\Pictures\1.xps", Quality:=xlQualityMinimum, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
        False
End Sub


Merci d'avance

Cordialement

achgel

cs_Le Pivert · Answer

Bonjour,

comme ceci avec une variable: 

Sub Enregistrer_sousTEST()
Dim nom As String
ActiveWindow.SmallScroll Down:=-12
Rows("18:18").Select
ActiveWindow.FreezePanes = False
ActiveWindow.SmallScroll Down:=-15
Range("A1:E81").Select
ActiveWindow.SmallScroll Down:=-33
Range("H34").Select
ActiveWindow.SmallScroll Down:=-30
Range("A1:E45").Select
ActiveWindow.SmallScroll Down:=-9
nom = Range("E11").Value
Range("A3:E46").Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypeXPS, Filename:= _
"C:\Users\Med\Pictures\" & nom & ".xps", Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
End Sub


évite le Select. Tu peux remplacer:

Range("H34").Select
ActiveWindow.SmallScroll Down:=-30

par

Range("H34").ActiveWindow.SmallScroll Down:=-30


 etc. pour les autres

cs_Le Pivert · Answer

Si le fichier est enregistré dans le même dossier , une alerte le signale automatiquement.
Par contre si ce n'est pas dans le même dossier et que tu ne veux pas 2 fichiers ayant le même nom, voici une petite macro à mettre dans la feuille où se trouve la cellule de saisie du nom du fichier: 

Option Explicit
Dim nom As String
Dim DerLig As Integer
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Application.Intersect(Target, Range("E11")) Is Nothing Then
nom = Target.Value
DerLig = Range("A65535").End(xlUp).Row
doublons
End If
End Sub
Private Sub doublons()
Dim c As Range
For Each c In Range("A2", "A" & DerLig)
    If c.Value = nom Then
      nom = ""
     MsgBox "Le nom de ce fichier existe, veuillez le changer!"
     Else
       Range("A" & DerLig + 1) = nom
    End If
    Next c
End Sub

cs_Le Pivert · Answer

Voilà un exemple a adapter:

http://www.cjoint.com/c/EKwr7SNDwNQ

cs_Le Pivert · Answer

Voilà beaucoup plus simple:

Option Explicit
Dim nom, sNomFichierXPS, chemin, NomFich As String
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Application.Intersect(Target, Range("E11")) Is Nothing Then
nom = Target.Value
End If
End Sub
Sub Enregistrer_sousTEST()
chemin = Range("E1").Value
ActiveWindow.SmallScroll Down:=-12
Rows("18:18").Select
ActiveWindow.FreezePanes = False
ActiveWindow.SmallScroll Down:=-15
Range("A1:E81").Select
ActiveWindow.SmallScroll Down:=-33
Range("H34").Select
ActiveWindow.SmallScroll Down:=-30
Range("A1:E45").Select
ActiveWindow.SmallScroll Down:=-9
nom = Range("E11").Value
If nom = "" Or chemin = "" Then Exit Sub
Range("A3:E46").Select
sNomFichierXPS = chemin & nom & ".xps"
NomFich = Dir(sNomFichierXPS)
If NomFich <> "" Then
MsgBox "LeFichier Existe"
Exit Sub
Else
ActiveSheet.ExportAsFixedFormat Type:=xlTypeXPS, Filename:=sNomFichierXPS _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
MsgBox "Votre XPS " & nom & "  est enregistré."
End If
End Sub

cs_Le Pivert · Answer

Voilà prêt à l'emploi:


 http://www.cjoint.com/c/EKyhewFNPbQ

Sauvegarder fichier Excel sous forme XPS

5 réponses

Newsletters