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

Signaler
Messages postés
5
Date d'inscription
jeudi 14 février 2019
Statut
Membre
Dernière intervention
15 février 2019
-
Messages postés
5
Date d'inscription
jeudi 14 février 2019
Statut
Membre
Dernière intervention
15 février 2019
-
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

1 réponse

Messages postés
6814
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
23 juin 2020
525
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




Messages postés
6814
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
23 juin 2020
525
Non, mon navigateur a bloqué ce fichier considéré comme dangereux

Mais avec les explications données, cela est très facile à mettre en place. Il faudrait savoir où ça bloque?
Messages postés
5
Date d'inscription
jeudi 14 février 2019
Statut
Membre
Dernière intervention
15 février 2019

https://www.cjoint.com/c/IBooZUWKMEp

ça devrait être bon !!
Messages postés
6814
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
23 juin 2020
525
non plus, je ne veux pas télécharger des fichiers corrompus. Je pense que tu peux te débouiller tout seul

@+
Messages postés
6814
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
23 juin 2020
525
Voilà un exemple:

https://www.cjoint.com/c/IBorNZzK8GQ

@+ Le Pivert
Messages postés
5
Date d'inscription
jeudi 14 février 2019
Statut
Membre
Dernière intervention
15 février 2019

Merci beaucoup pour tes explications ! j'ai repris ton fichier ou la macro fonctionne parfaitement, je vais calquer mon fichier initial sur le tien! Je vais essayer de comprendre ton raisonnement par la suite. AU TOP PIVERT!