Incrémenter le nom d'un fichier à sa sauvegarde

**Miigui** · 11/09/2017, 10h12

Bonjour à tous!

J'espère que le weekend a été bon! Aujourd'hui je vous sollicite dans l'espoir de trouver une réponse à mon problème.
Effectivement, j'ai beaucoup du mal à incrémenter le nom d'un fichier par le biais d'une macro.

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
 
 
Call SaveAsFile(Wbk)
 
End Sub
 
Public Function SaveAsFile(ByVal Wbk As Workbook)
 
Dim fso As Object
Dim FsoRepertoire As Object
Dim FsoFichier As Object
Dim str() As String
Dim i As Byte
Dim StrPrefixeFichier As String
 
StrPrefixeFichier = "REF_COMP_"
 
Set fso = CreateObject("Scripting.FileSystemObject")
Set FsoRepertoire = fso.GetFolder(ThisWorkbook.Path)
 
'Boucle sur fichiers du repertoire
For Each FsoFichier In FsoRepertoire.Files
    str = Split(FsoFichier.Name, ".")
        If str(UBound(str)) = "xls" And Left(str(0), Len(StrPrefixeFichier)) = StrPrefixeFichier Then
        If IsNumeric(Right(str(0), 2)) Then
            If Val(Right(str(0), 2)) > i Then i = Val(Right(str(0), 2))
        End If
    End If
Next
 
i = i + 1
 
Wbk.SaveAs StrPrefixeFichier & IIf(Len(i) = 1, "0" & i, i) & ".xls"
 
End Function

Dans le programme ci-dessus, je n'arrive pas à incrémenter. Le nom du fichier reste avec l'indice 01...
Donc voilà j'aimerai qu'on me dépanne de manière à incrémenté mes fichier de la façon suivante :

REF_COMP_00
REF_COMP_01
REF_COMP_02

Merci d'avance pour votre aide.

**RyuAutodidacte** · 11/09/2017, 10h28

Bonjour,

Dans ta boucle ne gère pas la variable i, par défaut i = 0
Normal qu'à i =i +1 donne 1 Je suis allé un peu trop vite en lisant sur mon phone, mais quoi qu'il en soit il y'a une mauvaise gestion à ce niveau, le pas à pas est requis

tu compares tes numériques en mettant toujours le plus grand dans une variable que tu auras initialisé
Soit
Dans ta boucle , récupère tes valeur numériques dans un Array et après la boucle utilise la formule avec Max.

Il ne reste plus qu'à incrémenter de + 1

**kiki29** · 11/09/2017, 10h30

Salut, voir ici pour un problème similaire via une fonction.

**Miigui** · 11/09/2017, 11h18

Envoyé par RyuAutodidacte

Bonjour,

Dans ta boucle ne gère pas la variable i, par défaut i = 0
Normal qu'à i =i +1 donne 1 Je suis allé un peu trop vite en lisant sur mon phone, mais quoi qu'il en soit il y'a une mauvaise gestion à ce niveau, le pas à pas est requis

tu compares tes numériques en mettant toujours le plus grand dans une variable que tu auras initialisé
Soit
Dans ta boucle , récupère tes valeur numériques dans un Array et après la boucle utilise la formule avec Max.

Il ne reste plus qu'à incrémenter de + 1

Très bien. Merci pour ta réponse rapide. Je vais voir ce que je peux faire.

**kiki29** · 11/09/2017, 11h37

Salut, voilà ce que cela donne

**Miigui** · 11/09/2017, 11h56

Envoyé par kiki29

Salut, voilà ce que cela donne

Comment as tu fait ?

Je n'arrive pas à faire l'incrémentation. REF_COMP_.xlsx est le seul fichier que je puisse créer. Ensuite lorsque je le ferme et relance la macro, lors de la sauvegarde on me demande si je souhaite écraser ...

**Miigui** · 11/09/2017, 11h57

Voilà le code entier :

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
48
49
50
51
52
53
54
55
56
57
58
Public Sub REF_COMP()
 
Dim Wbk, thisWbk As Excel.Workbook
Dim Sht, thisSht As Excel.Worksheet
Dim FileName, Fichier, Chemin As String
Dim LR, i As Long
 
Set thisWbk = ThisWorkbook
Set thisSht = thisWbk.Sheets("Export")
Set Wbk = Workbooks.Add ' On ajoute un classeur
'Set Sht = Wbk.Sheets("Current")
 
 thisWbk.Activate
 thisSht.Activate
 Cells.Select
 Application.CutCopyMode = False
 Selection.Copy
 Wbk.Activate
 Cells.Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Supprime les ligne érronées
 LR = Range("A" & Rows.Count).End(xlUp).row
 For i = LR To 1 Step -1
    If IsError(Range("A" & i)) Then Rows(i).Delete
 Next i
 
' Création du nom du fichier
   Chemin = ThisWorkbook.Path
   FileName = "REF_COMP_"
 
Fichier = RenommerFichier(Chemin, FileName)
Wbk.SaveAs FileName:=Fichier
 
End Sub
 
Private Function RenommerFichier(ByVal sDossier As String, ByVal sNomfichier As String) As String
Dim sNouveauNom As String
Dim sPre As String, sExt As String
Dim i As Long
Dim FSO As Object
 
   Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(sDossier & "\" & sNomfichier) Then
        sNouveauNom = sNomfichier
        sPre = FSO.GetBaseName(sNomfichier)
        sExt = FSO.GetExtensionName(sNomfichier)
 
        i = 0
        While FSO.FileExists(sDossier & "\" & sNouveauNom)
            i = i + 1
            sNouveauNom = sPre & Chr(40) & Format(i, "000") & Chr(41) & Chr(46) & sExt
        Wend
        sNomfichier = sNouveauNom
    End If
    Set FSO = Nothing
 
   RenommerFichier = sDossier & "\" & sNomfichier
End Function

**kiki29** · 11/09/2017, 12h11

Salut, extrait de ceci

L'extension proposée par défaut lors de l'enregistrement d'un classeur est le type .xlsx.

Les autres extensions XML sont:
* Classeur autorisant les macros (.xlsm)
* Modèle par défaut (.xltx)
* Modèle autorisant les macros (.xltm)
* Macro complémentaire (.xlam)
* Le dernier format .xlsb, est une version binaire non XML.

La lettre x en fin d'extension signifie que le fichier ne contient aucune macro. La lettre m signifie que le fichier contient des macros. Si vous enregistrez et fermez votre classeur au format .xlsx alors qu'il contenait des macros, celles ci seront perdues.

Donc quel format en sauvegarde : xls, xlsx etc ?

Tu as un exemple pour une feuille ici, à adapter à ton contexte.

**Miigui** · 11/09/2017, 12h19

Je sauvegarde sous le format xlsx

**kiki29** · 11/09/2017, 12h25

Re, à toi de poursuivre ton salmigondis.

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
Option Explicit
 
Private Function RenommerFichier(sDossier As String, sNomFichier As String) As String
Dim sNouveauNom As String
Dim sPre As String, sExt As String
Dim i As Long
Dim FSO As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(sDossier & "\" & sNomFichier) Then
        sNouveauNom = sNomFichier
        sPre = FSO.GetBaseName(sNomFichier)
        sExt = FSO.GetExtensionName(sNomFichier)
 
        i = 0
        While FSO.FileExists(sDossier & "\" & sNouveauNom)
            i = i + 1
            sNouveauNom = sPre & Chr(40) & Format(i, "000") & Chr(41) & Chr(46) & sExt
        Wend
        sNomFichier = sNouveauNom
    End If
    Set FSO = Nothing
 
    RenommerFichier = sDossier & "\" & sNomFichier
End Function
 
Private Sub SaveAsFile()
Dim StrPrefixeFichier As String
Dim sNomFichier As String
    StrPrefixeFichier = "REF_COMP"
    sNomFichier = RenommerFichier(ThisWorkbook.Path, StrPrefixeFichier & ".xlsx")
    Application.DisplayAlerts = False
    ThisWorkbook.SaveAs Filename:=sNomFichier, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
End Sub
 
Sub Test()
    SaveAsFile
End Sub

**kiki29** · 11/09/2017, 13h01

Re, à toi de voir

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
48
49
50
51
52
53
54
55
56
57
58
59
60
61
Option Explicit
 
Sub Sauvegarde()
Dim WkbDest As Workbook, WkbDep As Workbook
Dim ShDest As Worksheet, ShDep As Worksheet
Dim LR As Long, i As Long
Dim sPrefixeFichier As String
Dim sNomfichier As String, Rng As Range
 
    Application.ScreenUpdating = False
    Set WkbDep = ThisWorkbook
    Set ShDep = WkbDep.Sheets("Export")
 
    Set WkbDest = Workbooks.Add
    Set ShDest = WkbDest.Worksheets(1)
    Set Rng = ShDep.UsedRange
 
    Rng.Copy ShDest.Range("A1")
 
    LR = ShDest.Range("A" & Rows.Count).End(xlUp).Row
    For i = LR To 1 Step -1
        If IsError(ShDest.Range("A" & i)) Then Rows(i).Delete
    Next i
 
    sPrefixeFichier = "REF_COMP"
    sNomfichier = RenommerFichier(ThisWorkbook.Path, sPrefixeFichier & ".xlsx")
 
    Application.DisplayAlerts = False
    WkbDest.SaveAs FileName:=sNomfichier, FileFormat:=xlOpenXMLWorkbook
    WkbDest.Close savechanges:=True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
 
    Set Rng = Nothing
    Set WkbDep = Nothing
    Set WkbDest = Nothing
End Sub
 
Private Function RenommerFichier(ByVal sDossier As String, ByVal sNomfichier As String) As String
Dim sNouveauNom As String
Dim sPre As String, sExt As String
Dim i As Long
Dim FSO As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(sDossier & "\" & sNomfichier) Then
        sNouveauNom = sNomfichier
        sPre = FSO.GetBaseName(sNomfichier)
        sExt = FSO.GetExtensionName(sNomfichier)
 
        i = 0
        While FSO.FileExists(sDossier & "\" & sNouveauNom)
            i = i + 1
            sNouveauNom = sPre & Chr(40) & Format(i, "000") & Chr(41) & Chr(46) & sExt
        Wend
        sNomfichier = sNouveauNom
    End If
    Set FSO = Nothing
 
    RenommerFichier = sDossier & "\" & sNomfichier
End Function

**Miigui** · 11/09/2017, 14h46

Je me suis servi de la première solution qui marche correctement après l'avoir adapté à ma problématique.
Merci beaucoup, tu m'a été d'une grande aide!

Je vais essayer de modifier un petit peu de façons à commencer par REF_COMP_00.

**RyuAutodidacte** · 11/09/2017, 14h58

Re,

je réponds seulement à la demande de départ qui est l’incrémentation du nom, donc voilà un exemple à adapter :
NB : Code adapté pour marcher sur les 2 plateformes (PC et MAC)

Code :

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

1
2
3
4
5
6
7
Sub Exemple()
Dim Chm$, Prefix_Nom$, Sep$
    Sep = "\" ' "\" sur PC - ":" sur Mac Excel 2011 - "/" sur Mac Excel 2016
    Chm = ThisWorkbook.path & Sep
    Prefix_Nom = "REF_COMP_"
    MsgBox NewNom(Chm, Prefix_Nom)
End Sub

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
Function NewNom(Chm As String, Prefix_Nom As String) As String
Dim Fichier$, NumNom, N As Integer
    Fichier = Dir(Chm, vbDirectory)
    Do Until Fichier = vbNullString
    If Fichier Like Prefix_Nom & "*.xlsx" Then
        NumNom =Left(Split(Fichier, "_")(2), InStr(Split(Fichier, "_")(2), ".") - 1)
        If IsNumeric(NumNom) And NumNom > N Then N = NumNom
    End If
        Fichier = Dir()
    Loop
    NewNom = Prefix_Nom & Format(N + 1, "00") & ".xlsx"
End Function

Edit : ligne 6 de la fonction, sans le split c'est mieux :

Code :

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

NumNom = Mid(Fichier, InStrRev(Fichier, "_") + 1, InStrRev(Fichier, ".") - InStrRev(Fichier, "_") - 1)

Edit : petite correction sur la fonction

**RyuAutodidacte** · 11/09/2017, 23h41

Re,

Maintenant que j'ai un peu plus de temps voilà une fonction qui créé le nouveau classeur, supprime les #N/A, enregistre avec le nouveau nom incrémenté

PS : je l'ai testé sur Mac, mais sur PC ça devrait être ok, n'hésite pas à me dire si il y a un petit qq chose :

Code :

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

1
2
3
4
5
6
7
8
Sub MonSaveAs()
Dim Chm$, Prefix_Nom$, Sep$, Feuille$
    Sep = "\" ' "\" sur PC - ":" sur Mac Excel 2011 - "/" sur Mac Excel 2016
    Chm = ThisWorkbook.Path & Sep
    Prefix_Nom = "REF_COMP_"
    Feuille = "Export"
    MsgBox NewNameSaveAs(Chm, Prefix_Nom, Feuille)
End Sub

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
Function NewNameSaveAs(Chm As String, Prefix_Nom As String, Feuille As String) As String
Dim wb As Workbook, L As Range, Fichier$, NumNom$, N As Integer
 
    ThisWorkbook.Sheets(Feuille).Copy
    Set wb = ActiveWorkbook
    Application.ScreenUpdating = False
        With wb.ActiveSheet
            .UsedRange.Value = .UsedRange.Value
            .UsedRange.Sort Key1:=wb.ActiveSheet.Range("A1"), Order1:=xlAscending
            Set L = .Columns(1).Find("#N/A", LookIn:=xlValues, lookat:=xlWhole)
            .Rows(L.Row & ":" & .Cells(Rows.Count, 1).End(xlUp).Row).Clear
        End With
    Application.ScreenUpdating = True
 
    Fichier = Dir(Chm, vbDirectory)
    Do Until Fichier = vbNullString
    If Fichier Like Prefix_Nom & "*.xlsx" Then
        NumNom = Mid(Fichier, InStrRev(Fichier, "_") + 1, InStrRev(Fichier, ".") - InStrRev(Fichier, "_") - 1)
        If IsNumeric(NumNom) And NumNom > N Then N = NumNom
    End If
        Fichier = Dir()
    Loop
 
    NewNameSaveAs = Prefix_Nom & Format(N + 1, "00") & ".xlsx"
    Application.DisplayAlerts = False
        wb.SaveAs FileName:=Chm & NewNameSaveAs, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    wb.Close False:    Set wb = Nothing:    Set L = Nothing
End Function

PS 2 : normalement pour le tri il me semble que les # doivent être placés sur la fin de la colonne, si ce n'est pas le cas explique moi le résultat que tu as lors du tri (voir cette ligne ci-dessous) :

Code :

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

.UsedRange.Sort Key1:=wb.ActiveSheet.Range("A1"), Order1:=xlAscending

**Miigui** · 12/09/2017, 09h24

Merci beaucoup pour ton aide!
C'est super sympa de ta part. Je vais tester ça durant la matinée. Je te tiens au jus

**Miigui** · 12/09/2017, 11h33

Ca marche niquel, mais je n'en ressors pas indemne

**RyuAutodidacte** · 12/09/2017, 11h44

Envoyé par Miigui

…, mais je n'en ressors pas indemne

Que veux tu dire par là ?

Edit : j'avais omis de typé ma variable NumNom en string => c'est corrigé dans mon code du post 14 :
NumNom$

**Miigui** · 12/09/2017, 12h42

Seulement que ça m'a bien fait réflechir.
J'aime ça ahh
Merci beaucoup en tout cas

Incrémenter le nom d'un fichier à sa sauvegarde

Macros et VBA Excel

Discussions similaires

Partager

Partager