Discussion :

[niobium]

Bonjour à toutes et tous.

Qui pourrait 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\........(Fich).xls"

Merciiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiii ii.................

PS : cette macro a été trouvée sur le net et je sais plus où.... d'où ma demande.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
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

[Invité]

Bonjour,

A priori, nombreux seront ceux qui vous diront qu'il vaut mieux éviter les Goto.

Essayez ce code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Sub Enregistrement01()
 
Dim Rep As String, Fich As String, C As Byte, Cancel, Q As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Rep = "D:\" & Range("B2")
    If Dir(Rep) <> "" Then
    MkDir 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 !"
        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 = vbYes Then
        .SaveAs Rep & Fich & ".xls"
        Else
        Exit Sub
        End If
    Else
    .SaveAs Rep & Fich & ".xls"
    End If
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Ici j'ai considéré que sous-répertoire créé avec le contenu de "B2" était sous "D:\" mais vous vous modifier en "D:\Mes Documents".

J'ai aussi considéré que "B2" étant utilisé pour le nom du sous-répertoire, il ne l'était plus dans le nom du fichier.

D'autre part, je trouve bizarre cette ligne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Fich = Range("B2") & "_" & "_" & Range("C2") & "_" & "_" & Range("D1")

Que vous teniez à doubler le caractère "_" cela peut déjà paraître bizarre, mais c'est votre droit, seulement dans ce cas pourquoi ne pas écrire :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Fich = Range("B2") & "__" & Range("C2") & "__" & Range("D1")

[kiki29]

Salut,une remarque sur les caractères interdits , à priori :/\?*[]
d'autre part pour la création d'un dossier, à adapter à ton contexte

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
 
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 Integer
    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

Au final tu devrais avoir qqch comme

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
 
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
 (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
 
Option Explicit
 
Private Sub CreationDossier(sRepertoire As String)
Dim Rep As Integer
    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 Enregistrement()
Dim Rep As String, Fich As String, Answ As Integer
 
    Rep = "D:\Mes Documents\"
    With ActiveWorkbook
        Fich = Range("B2") & "_" & Range("C2") & "_" & Range("D1")
        Fich = NomValide(Fich)
 
        CreationDossier Rep
 
        If Dir(Rep & Fich & ".xls") <> "" Then
            Answ = MsgBox(Fich & ".xls Existe déjà, voulez-vous le remplacer ?", vbYesNo + vbDefaultButton2 + vbInformation)
            If Answ = 7 Then Exit Sub
        End If
 
        Application.DisplayAlerts = False
        .SaveAs Rep & Fich & ".xls"
        Application.DisplayAlerts = True
    End With
End Sub
 
Private Function NomValide(ByVal sNomFichier As String) As String
Const CaracInterdits As String = ":/\?*[]"
Dim i As Integer, Car As String * 1
 
    sNomFichier = Trim(sNomFichier)
 
    For i = 1 To Len(CaracInterdits)
        Car = Mid$(CaracInterdits, i, 1)
        sNomFichier = Replace(sNomFichier, Car, "")
    Next i
 
    NomValide = sNomFichier
End Function