Macre enregistrer sous - ajout du répertoire ?

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion niobium
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
N

niobium

Guest
'abuse de vous, je sais mais bon.....

Qui pourrais me modifier cette macro pour qu'elle enregistre le fichier dans un sous répertoire reprenant la valeur de B2 (nom_client) pour obtenir : "D:\Mes Documents\nom_client\fichier.xls"
Merciiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiii.................

Sub Enregistrement01()

Dim Rep As String, Fich As String, C As Byte, Cancel, Q As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Rep = "D:\Mes Documents\"

With ActiveWorkbook
Fich = Range("B2") & "_" & "_" & Range("C2") & "_" & "_" & Range("D1")
For C = 1 To Len(Fich) 'test caractères interdits
If InStr("\/:*?""""<>|", Mid(Fich, C, 1)) > 0 Then
MsgBox "Attention, il y a des des caractères interdits !"
Cancel = True
Exit Sub
End If
Next
If dir(Rep & Fich & ".xls") <> "" Then 'test existence fichier
Q = MsgBox(Fich & " Existe déjà, voulez-vous le remplacer ?", vbYesNo)
If Q = 7 Then GoTo Ligne1 Else GoTo Ligne2
Else: GoTo Ligne2
End If

Ligne1:
Cancel = True
Exit Sub
Ligne2:
.SaveAs Rep & Fich & ".xls"

End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
 
Trier par date Trier par votes
Re : Macre enregistrer sous - ajout du répertoire ?

Bonjour,

regarde le fichier joint..

Les codes :

Code: 
Sub Enregistrement01()
Dim Rep As String, Fich As String, C As Byte, Q As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False

If Range("B2").Value = "" Then Exit Sub
If Range("C2").Value = "" And Range("D1").Value = "" Then Exit Sub

Rep = "D:\Mes Documents\" & Range("B2").Value
If Not RépertoireExiste(Rep) Then
MakeDirEx (Rep$)
End If

With ActiveWorkbook
    Fich = Range("C2") & "_" & "_" & Range("D1")
        For C = 1 To Len(Fich) 'test caractères interdits
            If InStr("\/:*?""""<>|", Mid(Fich, C, 1)) > 0 Then
                MsgBox "Attention, il y a des des caractères interdits !"
                Exit Sub
            End If
        Next
    If Dir(Rep & "\" & Fich & ".xls") <> "" Then 'test existence fichier
        Q = MsgBox(Fich & " Existe déjà, voulez-vous le remplacer ?", vbYesNo)
        If Q = 7 Then
            Exit Sub
        Else
            .SaveAs Rep & "\" & Fich & ".xls"
        End If
    Else
        .SaveAs Rep & "\" & Fich & ".xls"
    End If
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

et les fonctions (des personnes en commentaire)

Code: 
Function RépertoireExiste(Chemin As String) As Boolean 'L. Longre
  On Error Resume Next
  RépertoireExiste = GetAttr(Chemin) And vbDirectory
End Function

Function MakeDirEx(DirPath$) As Boolean 'Frédéric Sigonneau
Dim i%, tmp, Arr
If InStr(1, DirPath, ":") = 0 Then
    Arr = Split(CurDir & "\" & DirPath, "\")
Else: Arr = Split(DirPath, "\")
End If
  
tmp = Arr(0)
For i = LBound(Arr) + 1 To UBound(Arr)
    If Arr(i) <> "" Then
        tmp = tmp & "\" & Arr(i)
        On Error Resume Next
        MkDir tmp
        On Error GoTo 0
    End If
Next
  
If Dir(DirPath, vbDirectory) = "" Then
    On Error Resume Next
    RmDir Arr(0) & "\" & Arr(1)
    On Error GoTo 0
Else
    MakeDirEx = True
End If
    
End Function

Bon dimanche
 

Pièces jointes

Vote positif 0 Vote négatif
Re : Macre enregistrer sous - ajout du répertoire ?

Re-,

Une petite rectification dans le code...

Il faut tester la valeur booléenne de MakeDirEx avant de continuer le code...

Aussi remplace cette ligne

Code: 
MakeDirEx (Rep$)

par :

Code: 
If Not MakeDirEx(Rep$) Then Exit Sub
 
Vote positif 0 Vote négatif
Re : Macre enregistrer sous - ajout du répertoire ?

Bonjour bhbh,enobiol


je viens de consulter ce fil, et me permet de le squater

Dis-moi bhbh, que faudrait-il modifier dans ce code,
afin de ne pouvoir enregistrer qu'une seule feuil du classeur, et sans le code???,

Plus de Pouvoir Nommer le classeur (Feuil)Enregistrée ainsi
en B4 "Un Nom"
en B5 "Un N°"

Ce qui donnerais a l'Enregistrement Nom du Dossier la Cell B2
Nom du Classeur(La feuil) la cell B4 et B5

Je ty'en remercie a l'avance

Bonne fin de journée
 
Dernière édition:
Vote positif 0 Vote négatif
Re : Macre enregistrer sous - ajout du répertoire ?

Bonjour,

remplace tout le code dans le module "Procédures" par celui-ci :

Code: 
Public Rep As String, Fich As String
Sub Enregistrement01()
Dim C As Byte, Q As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False

If Range("B2").Value = "" Then Exit Sub
If Range("B4").Value = "" And Range("B5").Value = "" Then Exit Sub

Rep = "D:\Mes Documents\" & Range("B2").Value
If Not RépertoireExiste(Rep) Then
If Not MakeDirEx(Rep$) Then Exit Sub
End If

With ActiveWorkbook
    Fich = Range("B4") & "_" & "_" & Range("B5")
        For C = 1 To Len(Fich) 'test caractères interdits
            If InStr("\/:*?""""<>|", Mid(Fich, C, 1)) > 0 Then
                MsgBox "Attention, il y a des des caractères interdits !"
                Exit Sub
            End If
        Next
    If Dir(Rep & "\" & Fich & ".xls") <> "" Then 'test existence fichier
        Q = MsgBox(Fich & " Existe déjà, voulez-vous le remplacer ?", vbYesNo)
        If Q = 7 Then
            Exit Sub
        Else
            CopierUneFeuilleSansCodeVBA "Feuil1"
            
        End If
    Else
        CopierUneFeuilleSansCodeVBA "Feuil1"
    End If
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub


Sub CopierUneFeuilleSansCodeVBA(NomFeuille$) ' Frédéric Sigonneau
ActiveWorkbook.Sheets(NomFeuille).Copy
With ActiveWorkbook
    With .VBProject.VBComponents(Sheets(NomFeuille).CodeName).CodeModule
        .DeleteLines 1, .CountOfLines
    End With
    .SaveAs Rep & "\" & Fich & ".xls"
End With
End Sub

Le nom de la feuille ("Feuil1") à adapter, bien sûr......
 
Vote positif 0 Vote négatif
Re : Macre enregistrer sous - ajout du répertoire ?

Salut à tous , juste une remarque pour le code concernant la création d'un dossier
Code: 
Option Explicit

Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
 (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long

Private Sub CreationDossier(sRepertoire As String)
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sRepertoire, 0&)
    ' Pour valeur retournée dans Rep
    ' Voir http://msdn.microsoft.com/en-us/library/ms681381(VS.85).aspx
End Sub

Sub Tst()
Dim sDossier As String
    sDossier = "D:\repA\repB\repC\repD\repE\repF"
    CreationDossier sDossier
End Sub
 
Vote positif 0 Vote négatif
Re : Macre enregistrer sous - ajout du répertoire ?

Trop Fort, génial, merciiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiii et super ! Bizzzzzzzz 😛


bhbh à dit:
Bonjour,

regarde le fichier joint..

Les codes :

Code: 
Sub Enregistrement01()
Dim Rep As String, Fich As String, C As Byte, Q As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False

If Range("B2").Value = "" Then Exit Sub
If Range("C2").Value = "" And Range("D1").Value = "" Then Exit Sub

Rep = "D:\Mes Documents\" & Range("B2").Value
If Not RépertoireExiste(Rep) Then
MakeDirEx (Rep$)
End If

With ActiveWorkbook
    Fich = Range("C2") & "_" & "_" & Range("D1")
        For C = 1 To Len(Fich) 'test caractères interdits
            If InStr("\/:*?""""<>|", Mid(Fich, C, 1)) > 0 Then
                MsgBox "Attention, il y a des des caractères interdits !"
                Exit Sub
            End If
        Next
    If Dir(Rep & "\" & Fich & ".xls") <> "" Then 'test existence fichier
        Q = MsgBox(Fich & " Existe déjà, voulez-vous le remplacer ?", vbYesNo)
        If Q = 7 Then
            Exit Sub
        Else
            .SaveAs Rep & "\" & Fich & ".xls"
        End If
    Else
        .SaveAs Rep & "\" & Fich & ".xls"
    End If
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

et les fonctions (des personnes en commentaire)

Code: 
Function RépertoireExiste(Chemin As String) As Boolean 'L. Longre
  On Error Resume Next
  RépertoireExiste = GetAttr(Chemin) And vbDirectory
End Function

Function MakeDirEx(DirPath$) As Boolean 'Frédéric Sigonneau
Dim i%, tmp, Arr
If InStr(1, DirPath, ":") = 0 Then
    Arr = Split(CurDir & "\" & DirPath, "\")
Else: Arr = Split(DirPath, "\")
End If
  
tmp = Arr(0)
For i = LBound(Arr) + 1 To UBound(Arr)
    If Arr(i) <> "" Then
        tmp = tmp & "\" & Arr(i)
        On Error Resume Next
        MkDir tmp
        On Error GoTo 0
    End If
Next
  
If Dir(DirPath, vbDirectory) = "" Then
    On Error Resume Next
    RmDir Arr(0) & "\" & Arr(1)
    On Error GoTo 0
Else
    MakeDirEx = True
End If
    
End Function

Bon dimanche
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
Re : Macre enregistrer sous - ajout du répertoire ?

Arffff, petit soucis avec cette ligne lorsque j'ouvre un classeur déjà créer dans son sous répertoire, si je relance la mcro il coince à cette ligne -- .SaveAs Rep & "\" & Fich & ".xls"-- car le fichier sauvegarder sur lui-même est toujours ouvert !


bhbh à dit:
Bonjour,

regarde le fichier joint..

Les codes :

Code: 
Sub Enregistrement01()

            .SaveAs Rep & "\" & Fich & ".xls"
        End If
    Else
        .SaveAs Rep & "\" & Fich & ".xls"
    End If
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

[/CODE]

Bon dimanche
Cliquez pour agrandir...
 
Dernière modification par un modérateur:
Vote positif 0 Vote négatif
Re : Macre enregistrer sous - ajout du répertoire ?

Bonjour,

effectivement, c'était une option non prévue dans le code...

rajoute la première et dernière ligne :

Code: 
    [COLOR="Red"]Application.DisplayAlerts = False[/COLOR]
    If Dir(Rep & "\" & Fich & ".xls") <> "" Then 'test existence fichier
        Q = MsgBox(Fich & " Existe déjà, voulez-vous le remplacer ?", vbYesNo)
        If Q = 7 Then
            Exit Sub
        Else
            
            .SaveAs Rep & "\" & Fich & ".xls"
        End If
    Else
        .SaveAs Rep & "\" & Fich & ".xls"
    End If
    [COLOR="Red"]Application.DisplayAlerts = True[/COLOR]
 
Vote positif 0 Vote négatif
Re : Macre enregistrer sous - ajout du répertoire ?

bhbh, merci pour ta gentillesse.... et ton SAV ! 😀

Mais cha coince toujours au même endroit !


bhbh à dit:
Bonjour,

effectivement, c'était une option non prévue dans le code...

rajoute la première et dernière ligne :

Code: 
    [COLOR="Red"]Application.DisplayAlerts = False[/COLOR]
    If Dir(Rep & "\" & Fich & ".xls") <> "" Then 'test existence fichier
        Q = MsgBox(Fich & " Existe déjà, voulez-vous le remplacer ?", vbYesNo)
        If Q = 7 Then
            Exit Sub
        Else
            
            .SaveAs Rep & "\" & Fich & ".xls"
        End If
    Else
        .SaveAs Rep & "\" & Fich & ".xls"
    End If
    [COLOR="Red"]Application.DisplayAlerts = True[/COLOR]
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
Re : Macre enregistrer sous - ajout du répertoire ?

Re-,

on va essayer autre chose..

Je teste si le fichier est déjà ouvert, et s'il l'est, on le sauvegarde, sinon, on le sauvegarde "Sous"...

Peut-être????

Code: 
Sub Enregistrement01()
Dim Rep As String, Fich As String, C As Byte, Q As String
Dim X As Byte
Application.ScreenUpdating = False
Application.DisplayAlerts = False

If Range("B2").Value = "" Then Exit Sub
If Range("C2").Value = "" And Range("D1").Value = "" Then Exit Sub

Rep = "D:\Mes Documents\" & Range("B2").Value
If Not RépertoireExiste(Rep) Then
MakeDirEx (Rep$)
End If

With ActiveWorkbook
    Fich = Range("C2") & "_" & "_" & Range("D1") & ".xls"
        For C = 1 To Len(Fich) - 4 'test caractères interdits
            If InStr("\/:*?""""<>|", Mid(Fich, C, 1)) > 0 Then
                MsgBox "Attention, il y a des des caractères interdits !"
                Exit Sub
            End If
        Next
    Application.DisplayAlerts = False
    On Error Resume Next
    X = Len(Workbooks(Fich).Name) 'Test si fichier déjà ouvert
    On Error Resume Next
    If Dir(Rep & "\" & Fich) <> "" Then  'test existence fichier
        Q = MsgBox(Fich & " Existe déjà, voulez-vous le remplacer ?", vbYesNo)
        If Q = 7 Then
            Exit Sub
        Else
                If X > 0 Then
                    .Save
                Else
                    .SaveAs Rep & "\" & Fich
                End If
        End If
    Else
        If X > 0 Then
            .Save
        Else
            .SaveAs Rep & "\" & Fich
        End If
    End If
    Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Assurez vous de marquer un message comme solution pour une meilleure transparence.

Discussions similaires

anthoYS
  • Résolu(e)
XL 2019 Adapter ce code, et améliorer le tableau avec graphique à l'année à y insérer ?
Réponses
4
Affichages
502
sylvanu
sylvanu
F
  • Question Question
XL 2021 bug "lib32" suite à passage à office 2021
Réponses
6
Affichages
435
fredl
F
N
  • Question Question
Microsoft 365 connexion ado vers access office 2024 64 bits
Réponses
2
Affichages
517
nabilexcel2007
N
S
  • Résolu(e)
Microsoft 365 Déclenchement macro en série suite à cellule fusionnées
Réponses
3
Affichages
538
spike29
S
thunder23
  • Résolu(e)
XL 2021 Bug dans code vba
Réponses
8
Affichages
823
thunder23
thunder23
C
  • Question Question
XL 2021 VBA excel
Réponses
4
Affichages
463
CDALE
C
C
  • Question Question
XL 2016 VBA - Mettre en Indice une partie du contenu d'une cellule : problème avec la propriété Font.Subscript
Réponses
2
Affichages
577
crocrocro
C
S
  • Question Question
XL 2013 enregistrer une feuille excel converti en pdf dans un répertoire selon la valeur d'une cellule
Réponses
5
Affichages
698
Phil69970
Phil69970
T
  • Résolu(e)
XL 2019 Filtrer certains champs au démarrage avec vba
2
Réponses
15
Affichages
1 K
telemarrk
T
F
  • Question Question
Microsoft 365 Problème mémoire insuffisante
Réponses
5
Affichages
926
TooFatBoy
TooFatBoy
A
  • Question Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
752
patricktoulon
patricktoulon
Q
  • Résolu(e)
Microsoft 365 Exécutions directes différentes vs "pas à pas"
Réponses
2
Affichages
679
Quentin2106
Q
C
  • Résolu(e)
XL 2021 Sauvegarder répertoire/sous répertoire un peu volumineux 2 Go
Réponses
7
Affichages
480
Claudinedu13
C
S
  • Résolu(e)
XL 2016 Coller nom classeur sur plage cellules
Réponses
9
Affichages
650
safranien
S
J
  • Question Question
Microsoft 365 macro qui ouvre des fichiers excel de type "analyze in excel" généré par power bi et met à jour un filtre "mois" sur plusieurs tcd
Réponses
0
Affichages
654
JJ69
J
F
  • Question Question
Microsoft 365 aide VBA excel
Réponses
4
Affichages
763
Oneida
Oneida
G
  • Résolu(e)
XL 2016 Pb de tri et sous totaux
2
Réponses
27
Affichages
2 K
Gestionnaire_rh
G
F
  • Résolu(e)
XL 2021 fermeture du classeur après apple d'un userform d'un autre classeur ouvert
Réponses
2
Affichages
462
farid
F
A
  • Question Question
XL 2016 Boucle sur sous répertoire fso.GetFolder SharePoint
Réponses
0
Affichages
1 K
Aldonanou
A
patricktoulon
Capturer et imprimer ou exporter en pdf un userform
Réponses
4
Affichages
625
PHV62
P
Retour