incrementation du nom d'un fichier

Version imprimable

Bonjour
j'ai le code suivant qui fonctionne tres bien pour une enregistrer sous. Seulement, dans le nom du fichier j'aimerais qu'un indice s'incremente quand un fichier est existant.
Exemple pour un premier enregistrement
1254_alignement_ERIC_00.xls
et si je fais un nouvel enregistrer sous je souhaiterais que le fichier s'enregistre sous le nom suivant
1254_alignement_ERIC_01.xls

Comment faire ? merci d'avance
Code:

1 2 3 4 5 'ENREGISTRER SOUS ActiveWorkbook.SaveAs Filename:=chemin & Range("gn1").Value & "_" & "_alignement_" & Range("b13").Value & ".xls", FileFormat:= _ xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=False

01/11/2011, 10h02
SfJ5Rpw8

Bonjour,
avant d'enregistrer tu teste l'existence du fichier avec une commande DIR ... et tant qu'il existe tu incrémente ton indice..
01/11/2011, 10h10
fmris

je ne connais pas cette fonction tu peux me donner un exemple en t'appuyant sur mon code stp ?
merci d'avance

je precise egalement que l'indice peut monter jusqu'a 10...

Bonjour,

Code non testé :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
'Réf. 111101.xlsm fmris
'ENREGISTRER SOUS
    Dim i As Integer, Fich As String, Res As Integer
    For i = 1 To 100
        Fich = Dir(chemin & Range("gn1").Value & "_" & "_alignement_" & Range("b13").Value & "_" & _
            Format(i, "00") & ".xls")
        If Fich = "" Then
            ActiveWorkbook.SaveAs Filename:=chemin & Fich, FileFormat:= _
            xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
            , CreateBackup:=False
            Exit For
        End If
    Next i

Bonjour
En adaptant la proposition de bbil, ci-joint une fonction qui permet de donner le premier indice libre

Code:

1
2
3
4
5
6
7
8
Function IndexFich(ByVal Chemin As String, Fichier As String) As Integer
Dim i As Integer
 
Do
    i = i + 1
Loop Until Dir(Chemin & Fichier & i & "*.xls") = ""
IndexFich = i
End Function

Dans ton cas, on l'appelle comme ci

Code:

1
2
3
4
5
6
7
8
9
10
11
Sub Test()
Dim Rep As String, Fich As String
 
Rep = "C:\Documents and Settings\Administrateur\Bureau\"    'Ajouter \ en dernier
With Worksheets("Feuil1")                                   'à adapter
    Fich = .Range("GN1").Value & "_alignement_" & .Range("B13").Value
End With
 
Fich = Rep & Fich & IndexFich(Rep, Fich) & ".xls"
ThisWorkbook.SaveAs Filename:=Fich, FileFormat:=xlNormal
End Sub

Bonjour,

Une autre méthode en utilisant FSO

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
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 = "1254_alignement_ERIC_"
 
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
 
ThisWorkbook.SaveAs StrPrefixeFichier  & IIf(Len(i) = 1, "0" & i, i) & ".xls"

EDIT : Ajout du test du nom de fichier.
Bien vu Daniel C:ccool:

01/11/2011, 17h17
Daniel.C

Bonjour,

Tu ne fais pas de test sur le nom du fichier ?