Excel VBA enregistrer fichier bureau & renommer par rapport à une cellule Résolu/Fermé

Question

Bonjour

je début sur les macro et j'ai besoin de votre aide. 

je m'explique: 

j'ai un classeur Excel avec plusieurs feuilles, seule la première est importante, les autres sont masquées". Pour l'ergonomie certaine cellules sont fusionnées. Sur la première feuille, précisément sur la cellule B7, je met un numéro à 8 chiffres ex"19005695". 

Après avoir complété mon tableau, j'aimerai créer un bouton TERMINÉ, qui lui m'enregistrera une copie de ce classeur sur le bureau sous le numéro de la cellule B7 "19005695", tout en conservant mon classeur initial vierge (sans les données). 

j'espère trouver une personne qui pourra d'aider, merci d'avance et surtout de votre patience. Merci d'avance pour votre aide précieuse

cs_Le Pivert · Answer

Bonjour,

Faire Alt F11 pour accéder à l'éditeur, ensuite insérer un Module.

Mettre ce code dans ce module: 

Option Explicit
Dim dossier As String
Dim bureau As String
Sub Enregistrer()
Application.DisplayAlerts = False
cheminbureau
dossier = bureau & "\"
 ActiveWorkbook.SaveAs Filename:=dossier & Sheets("Feuil1").Range("B7").Value & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
  MsgBox "Enregistrement du classeur sur le Bureau", vbInformation, "Enregistrement"
    Application.DisplayAlerts = 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


pour lancer la macro mettre un bouton aller dans Développeur, Mode Création:
Inserer control formulaire Bouton. Clic droit sur le bouton: 
Affecter une macro, sélectionner Enregistrer
Le bouton est opérationnel

Excel VBA enregistrer fichier bureau & renommer par rapport à une cellule

1 réponse

Discussions similaires