[XL-2019] Sauvegarde après création d'un classeur par VBA

Sauvegarde après création d'un classeur par VBA

Bonjour à l'aimable communauté

Je travaille sur Excel 2019
Je viens de créer une boite de dialogue dont les fonctionnalités sont les suivantes:
1- Rechercher un fichier sur le disque
2- Le sauvegarder dans un répertoire éphémère crée avec la racine D:\AFC_FMR_ + un nom de dossier saisi dans la textbox "Nom à donner..." (exemple D:\AFC_FMR_MonAnalyse)
3- Ouvrir ce nouveau fichier, trier ses lignes sur la premiere colonne (Code reference = les 3 premières digits de la valeur de la cellule)
4- Sélectionner la ligne titre + les lignes dont le code reference (3 premiers digit) correspond à celui de l'AL sélectionnée
5- Créer un fichier cible sous le répertoire éphémère dans lequel sont recopiées les lignes extraites pour le code AL demandé
6- Sauvegarder dans le répertoire éphémère le fichier cible sous le nom D:\AFC_FMR_Nom à donner_Code 3digit (exemple D:\AFC_FMR_MonAnalyse_103)

Je suis un peu honteux car il doit s'agir d'une erreur de débutant sur les déclarations. Je donne ma langue au chat pour pouvoir avancer.
Merci par avance pour le temps que vous aurez bien voulu consacrer à cette lecture et pour vos recommandations à venir :ave:
Bien cordialement
Ozabois

La macro fonctionne très bien jusqu'à l'étape 5. Mon problème se révèle à l'étape 6 avec une Erreur d'exécution 1004 au niveau de la dernière instruction :
ActiveWorkbook.SaveAs Filename:=sDossier & " \ " & NomEnquete & "-" & AL & ".xlsx"

Code:

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
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
 
 
Option Explicit
Private Sub Workbook_Open()        ' Dans This Workbook'
    UserForm1.Show
End Sub
 
 
Sub Parcourir()
 
 
    'selectionner une fichier à partir de l'explorateur de fichier
    Dim chemin As FileDialog
    Set chemin = Application.FileDialog(msoFileDialogFilePicker)
    chemin.AllowMultiSelect = False 'selection d'un seul fichier à la fois
    chemin.Title = "Sélectionnez votre fichier data"
    chemin.Filters.Clear
    chemin.Show
    UserForm1.TextBox1.Value = chemin.SelectedItems(1)
 
End Sub
 
 
 
Sub Process_Extract()
    Call CreationDossier    ' Création dossier et place une copie du fichier après l'avoir renommée
End Sub
 
 
Sub CreationDossier()   ' Création dossier et place une copie du fichier après l'avoir renommée
Dim sDossier As String
Dim sChaine As String
Dim NomEnquete As String
Dim NbL As Variant
Dim AL As Variant
Dim PL As Variant  ' Premmière Ligne de la tranche recherchée AL
Dim DL As Variant  ' Dernière Ligne de la tranche recherchée AL
Dim CodeAL As Variant  ' Code AL 3 digit
Dim CodeALP As Variant  ' Code AL 3 digit de l'enregistrement précédent
Dim Contenu As Variant ' Contenu de la cellule
Dim L As Variant ' Contenu de la cellule
Dim NomExtractAL As Workbooks  ' Nom de u fichier extract / AL
 
 
    ' Crée le dossier ephemère
    NomEnquete = UserForm1.TextBox5.Value
    sDossier = "D:\AFC_FMR_" & NomEnquete
    sChaine = Environ("comspec") & " /c mkdir " & sDossier
    Shell sChaine, 0
 
 
    ' Duplique le fichier d'une autre directory en changeant le nom
    Dim FichierOriginal
    Dim FichierCopie
    MkDir sDossier
 
 
    FichierOriginal = UserForm1.TextBox1.Value
    FichierCopie = sDossier & "\" & NomEnquete & ".xlsx"
 
    FileCopy FichierOriginal, FichierCopie
 
 
    Workbooks.Open (FichierCopie)
 
    ' Trie la table
    Range("A1").Select
    Selection.CurrentRegion.Select
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add2 Key:=Range("A2:A18") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange Range("A1:E18")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
    ' Recherche la tranche à extraire
    NbL = Cells(Rows.Count, 1).End(xlUp).Row
    AL = UserForm1.TextBox4.Value
    For L = 2 To NbL
        CodeAL = Left(Cells(L, 1).Value, 3)         ' Code AL sur la ligne
        CodeALP = Left(Cells(L - 1, 1).Value, 3)    ' Code AL de l'enregistrement précédent
 
        Select Case CodeAL
            Case Is = AL
                 If CodeALP <> AL Then PL = L
            Case Else
                If CodeALP = AL Then DL = L - 1
        End Select
    Next L
 
    Range("1:1," & PL & ":" & DL).Select
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste Destination:=Range("A1")
    ActiveWorkbook.SaveAs Filename:=sDossier & " \ " & NomEnquete & "-" & AL & ".xlsx"
 
 
 
End Sub

Salut,
Pas tout vérifié mais, tentes de supprimer les espaces avant et après le backslash

Code:

ActiveWorkbook.SaveAs Filename:=sDossier & "\" & NomEnquete & "-" & AL & ".xlsx"

En cadeau une fonction de Philippe Tulliez pour créer tes répertoires sans passer par des artifices...

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
' // CreateSubFolder By Philippe Tulliez
' // Nom du ou des répertoires à créer. Il y a lieu de séparés par un délimiteur s'il y a plus d'un répertoire
Sub CreateSubFolder(ByVal FullPath As String, ByVal RootFolder As String, Optional ByVal Delimiter As String = "\")
    Dim PathName As String
    Dim Tbl As Variant
    Dim Elem As Byte
    If IsMissing(Delimiter) Then Delimiter = Application.PathSeparator
    Tbl = Split(FullPath, Delimiter)
    PathName = RootFolder
    For Elem = 0 To UBound(Tbl)
        PathName = PathName & Delimiter & Tbl(Elem)
        If Dir(PathName, vbDirectory) = vbNullString Then MkDir PathName
    Next
End Sub

Bonjour Valtrase
Merci beaucoup de ta réponse rapide. :bravo:
J'ai bien honte: c'est bien les espaces autour du backslash qui créaient l'erreur. D'autant plus stupide que j'utilise déjà la même syntaxe qques lignes plus haut !
Merci aussi pour la fonction Philippe Tulliez, que je conserve au chaud.
Slts :chin: