Sauvegarder fichier Excel sous forme XPS

[Résolu/Fermé]
Signaler
Messages postés
108
Date d'inscription
mercredi 26 août 2009
Statut
Membre
Dernière intervention
25 octobre 2019
-
Messages postés
108
Date d'inscription
mercredi 26 août 2009
Statut
Membre
Dernière intervention
25 octobre 2019
-
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

5 réponses

Messages postés
7530
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
14 septembre 2021
655
Voilà prêt à l'emploi:


http://www.cjoint.com/c/EKyhewFNPbQ
1
Merci

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

CCM 42584 internautes nous ont dit merci ce mois-ci

Messages postés
108
Date d'inscription
mercredi 26 août 2009
Statut
Membre
Dernière intervention
25 octobre 2019
1
Bonsoir Le Pivert
j'ai utilisé uniquement la Macro lié à l'UserForm, puisque j'ai eu le même résultat
et VOTRE APPLICATION, pour ne pas dire mon application, fonctionne parfaitement bien

C'était vraiment très gentille de votre part
Merci infiniment
Messages postés
7530
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
14 septembre 2021
655
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
Messages postés
108
Date d'inscription
mercredi 26 août 2009
Statut
Membre
Dernière intervention
25 octobre 2019
1
Mille

Merci cs_Le Pivert

Grace à votre aide j'arrive maintenant à sauvegarder mes données Excel en XPS.

Est la Macro fonctionne parfaitement bien.



Juste pour vous informer, et pour éviter le Select.

J'ai remplacé

Range("H34").Select
ActiveWindow.SmallScroll Down:=-30

Par

Range("H34").ActiveWindow.SmallScroll Down:=-30

Et les autres aussi

Mais la sauvegarde n'a pas abouti



Cordialement

achgel
Messages postés
108
Date d'inscription
mercredi 26 août 2009
Statut
Membre
Dernière intervention
25 octobre 2019
1
Bonsoir

Est ce qu'il y'a un moyen pour que la Macro me donne un message signalant que le nom du ficher xps que j'essaye de sauvegarder existe déjà.
Puisque tout le monde pourra se tremper en saisissant un nom déjà existant

Merci d'avance
Messages postés
7530
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
14 septembre 2021
655
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


Messages postés
108
Date d'inscription
mercredi 26 août 2009
Statut
Membre
Dernière intervention
25 octobre 2019
1
Bonjour Le Pivert

J'ai copier la Macro dans la feuille où se trouve la cellule de saisie du nom du fichier, mais le fichier s'en registre dans l'emplacement prévu ("C:\Users\Med\Pictures\) avec un le Nom déjà existant avec les nouvelles données, et bien sur je perd les anciennes données.

Je compte beaucoup sur votre aide

Merci infiniment

Cordialement
Messages postés
7530
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
14 septembre 2021
655
Voilà un exemple a adapter:

http://www.cjoint.com/c/EKwr7SNDwNQ
Messages postés
7530
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
14 septembre 2021
655
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


Messages postés
108
Date d'inscription
mercredi 26 août 2009
Statut
Membre
Dernière intervention
25 octobre 2019
1
Merci Le Pivert

C'est bien ce que je cherchais

Mais j'ai encore deux petits soucies:

Le premier c'est que le Nom de la cellule "E11" apparaît en Double, comme nom du fichier .xps

Le deuxième c'est que je veux sauvegarder mes fichiers .xps dans l'emplacement suivent:

C:\Users\Med\Pictures\Result\Exm


Je vous souhaite de passer une excellente soirée.

Et merci infiniment


Cordialement