[VBA] Renommer classeur as copy à l'ouverture selon text box

Anthonymctm · 2 Juin 2020

Bonjour le forum,

J'ai trouvé quelques bouts de code sur le net mais je m'emmêle les pinceaux ^^'

J'ai un classeur bien fait qui doit rester vierge.
Pour éviter les fausses manip et parce que d'autre formule se base sur le nom du fichier, j'aimerais qu'à l'ouverture mon fichier vierge D20-XXXX-01, un text box (ou userform, je sais pas ce qui est le mieux) apparaissent et me demande le nom du fichier.

Ainsi je renseigne le nom du fichier D20-0633-01, le classeur vierge fait un SaveCopyAs dans le même répertoire avec le nom renseigné dans le text box.
Puis le fichier vierge peut se fermer sans enregistrer et le nouveau classeur reste ouvert, prêt à l'emploi.

Si on fait ça, ce sera déjà pas mal !

Tout ce qui suit est pour peaufiner tout ça.

-Il faudrait vérifier que le nom soit bien de la forme DXX-XXXX-XX (les X étant des nombres)
-Si le titre du classeur est déjà autre que D20-XXXX-01 (qui correspond au fichier vierge) alors inutile de demander de renommer.

Maintenant l'étape 2 serait que j'ai plusieurs possibilités à l'ouverture :
-Enregistrer copie selon le nom tapé (ça c'est la demande du dessus)
-Enregistrer copie sous un autre répertoire comme un enregistrer sous
-Annuler la demande et on sort de ce code comme si de rien n'étais

L'étape 3 serait d'avoir un champ numéro devis pour remplacer les 4 XXXX, un deuxième champ indice devis pour les deux derniers XX puis un champ final qui se remplisa partir des champs précédent à savoir : D"année en cours"-"numéro devis"-"indice devis" comme D20-0633-01

L'étape 4 serait carrément d'aller chercher dans notre base SQL le dernier devis créé avec la requête SQL SELECT max(codedevis) from TableDevis mais là on y est pas encore

jmfmarques · 2 Juin 2020

Bonjour

Intéresse-toi à ce qu'est et comment fonctionne un classeur modèle.
Le modèle n'est jamais altéré et il génère seul un nouveau classeur que l'on sauvegarde (ou abandonne) ensuite où et comment on le souhaite.

Anthonymctm · 2 Juin 2020

jmfmarques à dit:
Bonjour

Intéresse-toi à ce qu'est et comment fonctionne un classeur modèle.

Alors je ne m'étais jamais intéressé aux modèles, merci pour la découverte ça pourra me servir en effet !
Par contre ça ne m'aide pas pour simplifier la création et le nommage du fichier doublon

Anthonymctm · 8 Juin 2020

Un petit up.

J'en suis là, ça à l'aire de bien fonctionner !

VB:

Private Sub Workbook_Open()
 
Dim ND, FirstWord, LastWord, MidWords
Dim Msg, Style, Title, Help, Ctxt, Response
 
If ThisWorkbook.Name = "Devis - Vierge.xlsm" Then
 
ND = Application.InputBox("Saisir le n° devis", , "D" & Right(Year(Now), 2) & "-XXXX-XX", Type:=2)
 
 
FirstWord = Mid(ND, 1, 4)    ' Returns "DXX-"
MidWord = Mid(ND, 5, 4)    ' Returns "XXXX"
LastWord = Mid(ND, 9, 3)    ' Returns "-XX"
 
 
 If FirstWord = "D" & Right(Year(Now), 2) & "-" And MidWord Like "[0-9][0-9][0-9][0-9]" And LastWord Like "-[0-9][0-9]" Then
 
ActiveWorkbook.SaveAs Filename:=Application.ActiveWorkbook.Path & "\" & ND
 
 Else
 
Msg = "Votre n° doit être de la forme : D" & Right(Year(Now), 2) & "-XXXX-XX" & vbCrLf & "Réessayer ?"
Style = vbYesNo + vbCritical + vbDefaultButton1
Title = "Erreur dans le numéro de devis"
Help = "DEMO.HLP"
Ctxt = 1000
 
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
 
    If Response = vbYes Then
    Workbook_Open
    Else
    MsgBox "Saisie annulée" & vbCrLf & "Attention : fichier original"
    End If
 
 End If
End If
 
End Sub

Maintenant ce serait bien que j'ai la capacité d'enregistrer sous, pour changer la destination.
Quand j'ai ma première demande de saisie, avoir un troisième bouton serait bien.
On aurait : - Ok (qui enregistre comme actuellement au même endroit)
- Enregistrer sous (qui ouvre la fenetre)
- Annuler (comme actuellement qui suit la procédure)

Anthonymctm · 10 Juin 2020

VB:

Private Sub Workbook_Open2()

Dim nDevis, FirstWord, LastWord, MidWord
Dim Msg, Style, Title, Help, Ctxt, Response
Dim Sauvegarde As Variant, Question As Integer


If ThisWorkbook.Name = "Devis - D" & Right(Year(Now), 2) & "-XXXX-01.xlsm" Then

nDevis = InputBox("Saisir le n° devis (D" & Right(Year(Now), 2) & "-XXXX-XX)", , "D" & Right(Year(Now), 2) & "-XXXX-01")
    
If nDevis Like "D##-####-##" Then

 On Error GoTo ErrorHandler 'Voir Label ErrorHandler:
 ActiveWorkbook.SaveAs Filename:=Application.ActiveWorkbook.Path & "\" & nDevis
  On Error GoTo 0            'On anulle le on error
MsgBox "Numéro devis enregistré"

 Else
 
msg2:
Msg = "Votre n° doit être de la forme : D" & Right(Year(Now), 2) & "-XXXX-XX" & vbCrLf & vbCrLf & "Réessayer      Enregistrer sous" & vbCrLf & "    |                               |" & vbCrLf & "   \/                              \/"
Style = vbYesNoCancel + vbExclamation + vbDefaultButton1
Title = "Erreur dans le numéro de devis"
Help = "DEMO.HLP"
Ctxt = 1000

Response = MsgBox(Msg, Style, Title, Help, Ctxt)

    If Response = vbYes Then
    Workbook_Open2
    ElseIf Response = vbNo Then ' Demande ou sauver le doc et le nom à lui donner
    
        If nDevis = "" Then
        nDevis = "D" & Right(Year(Now), 2) & "-XXXX-01"
        End If
Sauvegarde = Application.GetSaveAsFilename(ActiveWorkbook.Path & "\Devis - " & nDevis & ".xlsm", FileFilter:="XLSM (*.xlsm), *.xlsm", Title:="Enregistrer-sous ...")
' Demande ou sauver le doc et le nom à lui donner
If Sauvegarde = False Then GoTo msg2
' Si click sur annuler, alors on revient a la boite de dialoque
If Dir(Sauvegarde) <> "" Then ' le fichier renseigné par l'utilisateur existe-t-il ?
   Question = MsgBox("Attention le fichier existe déjà" & Chr(13) & "Voulez vous le remplacer ?", vbQuestion + vbYesNo, "Attention...")
   ' Si oui, faut t-il l'effacer ?
   If Question = 6 Then ' Oui
      Kill Sauvegarde ' Efface
   Else ' Non
      GoTo msg2 ' On revient a la boite de dialoque
   End If
End If
ThisWorkbook.SaveAs Sauvegarde ' Sauvegarde
  Else: MsgBox "Saisie annulée" & vbCrLf & "Attention : fichier original"
    End If
    
 End If
End If
Exit Sub

ErrorHandler:
If Err.Number = 1004 Then 'Si on annule la Boite de dialog "écraser..."
    Workbook_Open2
Else
    MsgBox "Erreur imprévue : " & Err.Number & vbCrLf & Err.Description
End If

End Sub

Voilà, la macro terminée

[VBA] Renommer classeur as copy à l'ouverture selon text box

Anthonymctm

XLDnaute Occasionnel

jmfmarques

XLDnaute Accro

Anthonymctm

XLDnaute Occasionnel

Anthonymctm

XLDnaute Occasionnel

Anthonymctm

XLDnaute Occasionnel

Discussions similaires