Discussion :

[LinC49]

Bonjour à tous,

Je reviens vers vous pour vous demandez quelques conseils vis à vis de mon petit problème.

Je m'explique j'ai un classeur de base (nommé "vierge"), et lorsque celui ci s'ouvre une demande de sauvegarde s'opère et lors de cette demande l'utilisateur ajoute le nom du classeur et ensuite le code vba fournir un numéro automatique.
Mais le souci est que j'aimerais à partir du classeur de base ("vierge) pouvoir continuer la suite des numéros automatique. c'est pas très claire je vais faire un exemple :

à partir du classeur nommé " Vierge"
avoir _ ClasseurA1
_ ClasseurB2
_ .....

en claire il faudrait que dans mon code ( du classeur "Vierge"), il puisse faire une recherche dans le dossier et dire par exemple s'il y a un classeur ayant le numéro 1 il va mettre le numéro 2 et ainsi de suite. est-ce fesable??? si oui pouvez vous me donner quelques pistes à suivre?

Dans ce fichier ci-joint, j'ai réussi à faire le numero automatique et la recherche dans le dossier mais je bloque au niveau de la condition ( le if)


De plus pensez vous qu'après la sauvegarde, le nom + son numero peut etre intégré dans un textbox situé dans un UserForm?

Merci beaucoup pour votre aide

Cordialement

[mercatog]

Essaies cette gymnastique comme ceci (si j'ai bien compris)

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
Private Sub Workbook_Open()
Dim Chemin As String, Titre As String, Nom As String, Res As String
Dim i As Integer
Dim Tblo
 
If MsgBox("Enregistrer le fichier maintenant ?", vbYesNo + vbQuestion, "Sauvegarde du fichier") = vbYes Then
    Chemin = "C:\Documents and Settings\SCCI08881\Bureau\Céline_Stage\test"
    Titre = InputBox("Indiquer le nom du fichier :")
    Nom = Dir(Chemin & "\" & Titre & "*.xls")
    If Nom <> "" Then
        ReDim Tblo(1 To 1)
        Tblo(1) = Replace(Replace(Nom, ".xls", ""), Titre, "")
        Do While Nom <> ""
            i = i + 1
            ReDim Preserve Tblo(1 To i + 1)
            Nom = Dir()
            Tblo(i + 1) = Replace(Replace(Nom, ".xls", ""), Titre, "")
        Loop
        Res = Join(Tblo, "_")
        For i = 1 To UBound(Tblo)
            If InStr(Res, i & "_") = 0 Then Exit For
        Next i
        Titre = Titre & i & ".xls"
    Else
        Titre = Titre & "1.xls"
    End If
    ThisWorkbook.SaveAs Chemin & "\" & Titre
End If
End Sub

[Theze]

Bonjour,

La proc boucle sur les fichiers du dossier jusqu'à trouver un nom "libre" en incrémentant à chaque passe la variable "num" de 1. Par défaut, dans l'inputBox c'est le nom du classeur qui est entrée (dans ton cas, "Vierge"). A adapter :

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
 
Private Sub Workbook_Open()
 
    Dim Repertoire As String
 
    'Boite de dialogue, si Oui
    If MsgBox("Enregistrer le fichier maintenant ?", _
              vbYesNo + vbQuestion, _
              "Sauvegarde du fichier") = vbYes Then
 
        'définir le chemin de MesDocuments
        Repertoire = "C:\Documents and Settings\SCCI08881\Bureau\Céline_Stage\test\"
 
        'Boite de dialogue demandant le nom du classeur à enregistrer
        'avec par défaut le nom du classeur contenant cette proc
        titre = InputBox("Indiquer le nom du fichier :", _
                         "Nom du classeur.", _
                         Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1))
 
        'si aucune saisie, fin
        If titre = "" Then Exit Sub
 
        'boucle sur les fichiers jusqu'à trouver un nom unique
        Do
            num = num + 1
            newnom = titre + CStr(num) + ".xls"
 
        Loop Until Dir(Repertoire & newnom) = ""
 
        'Enregistrer le fichier
        ActiveWorkbook.SaveAs Repertoire & newnom
 
    End If
 
End Sub

Hervé.

[LinC49]

Avant tout merci pour vos réponses.

Mais j'ai dut mal m'exprimer! Vos 2 codes permettent de poursuivre la numérotation si le nom du classeur est le même. Alors que j'aimerais que même si le nom du classeur est différent la numérotation continue.

En application : a chaque fois que je veux créer un nouveau classeur, j'ouvre le classeur (nommé "vierge") qui me lance la sauvegarde à l'ouverture. Ensuite les utilisateurs inscrivent n'importe quel nom pour le classeur, et le code rajoute le numéro. Donc dans le dossier il ne peut pas y avoir plusieurs fichiers excel portant le numéro 1 ou 2 ou 3....

Du coup je pense qu'il faut faire une recherche sur les noms des fichiers excel et si dans les noms il y a un 1 ou un 2 ou un 3.... et bien pour le nouveau classeur faire + 1 pour son numero auto

Qu'en pensez vous???

J'espère que mes explications ont été claire

cordialement

[mercatog]

Avec un risque sur la conception

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
Private Function ExtrNum(Mot As String) As Integer
Dim i As Integer
 
For i = Len(Mot) To 1 Step -1
If Not IsNumeric(Mid(Mot, i, 1)) Then Exit For
Next i
If i > 1 And i < Len(Mot) Then ExtrNum = Val(Mid(Mot, i + 1))
End Function
 
Private Sub Workbook_Open()
Dim Chemin As String, Titre As String, Nom As String, Res As String
Dim i As Integer
Dim Tblo() As String
 
If MsgBox("Enregistrer le fichier maintenant ?", vbYesNo + vbQuestion, "Sauvegarde du fichier") = vbYes Then
   Chemin = "C:\Documents and Settings\SCCI08881\Bureau\Céline_Stage\test"
   Titre = InputBox("Indiquer le nom du fichier :")
   Nom = Dir(Chemin & "\*.xls")
   If Nom <> "" Then
      Nom = Replace(Nom, ".xls", "")
      ReDim Tblo(1 To 1)
      Tblo(1) = "LinC" & ExtrNum(Nom)
      Do While Nom <> ""
         Nom = Dir()
         Nom = Replace(Nom, ".xls", "")
         If ExtrNum(Nom) <> 0 Then
            i = i + 1
            ReDim Preserve Tblo(1 To i + 1)
            Tblo(i + 1) = "LinC" & ExtrNum(Nom)
         End If
      Loop
      Res = Join(Tblo, "_")
      For i = 1 To UBound(Tblo)
         If InStr(Res, "LinC" & i & "_") = 0 Then Exit For
      Next i
      Titre = Titre & i & ".xls"
   Else
      Titre = Titre & "1.xls"
   End If
   ThisWorkbook.SaveAs Chemin & "\" & Titre
End If
End Sub

[Theze]

Bonsoir,

Alors, comme Mercatog pour son code ;o)), mon code modifié avec les explications dans le 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
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
105
106
107
 
Private Sub Workbook_Open()
 
    Dim Tbl() As String
    Dim Repertoire As String
    Dim N As String
    Dim Titre As String
    Dim NewNom As String
    Dim NBFich As Integer
    Dim I As Integer
    Dim J As Integer
    Dim Num As Integer
 
    'Boite de dialogue, si Oui
    If MsgBox("Enregistrer le fichier maintenant ?", _
              vbYesNo + vbQuestion, _
              "Sauvegarde du fichier") = vbYes Then
 
        'définir le chemin de MesDocuments
        Repertoire ="C:\Documents and Settings\SCCI08881\Bureau\Céline_Stage\test\"
 
        'Boite de dialogue demandant le nom du classeur à enregistrer
        'avec par défaut le nom du classeur contenant cette proc
        Titre = InputBox("Indiquer le nom du fichier :", _
                         "Nom du classeur.", _
                         Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1))
 
        'si aucune saisie, fin
        If Titre = "" Then Exit Sub
 
        'récupère tous les classeurs du dossier (voir fonction ci-dessous)
        Tbl = Fichiers(Repertoire, "xls")
 
        'gère l'erreur du tableau vide
        On Error Resume Next
 
        'nombre de classeurs (erreur si aucun classeur)
        NBFich = UBound(Tbl)
 
        'affiche un message si pas de classeur dans le dossier et fin
        If Err.Number <> 0 Then
 
            MsgBox "Aucun fichier dans le dossier '" & Repertoire & "' !"
            Exit Sub
 
        End If
 
        'remet le gestionnaire à zéro
        On Error GoTo 0
 
        'parcour le tableau de fichiers
        For I = 1 To NBFich
 
            'recherche les chiffres dans les noms et incrémente
            'et récupère le nombre le plus élevé
            For J = 1 To Len(Tbl(I))
                If InStr("1234567890", Mid(Tbl(I), J, 1)) <> 0 Then
                    N = N & Mid(Tbl(I), J, 1)
                End If
            Next J
 
            'gère l'erreur du N = ""
            On Error Resume Next
 
            'affecte le nombre le plus élevé à Num
            If CInt(N) > Num Then Num = CInt(N)
 
            N = ""
 
        Next I
 
        'incrémente de 1 et construit le nom
        Num = Num + 1
        NewNom = Titre + CStr(Num) + ".xls"
 
        'Enregistrer le fichier
        ActiveWorkbook.SaveAs Repertoire & NewNom
 
    End If
 
End Sub
 
Function Fichiers(Chemin As String, Extension As String) As String()
 
    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer
 
    Fichier = Dir(Chemin)
 
    Do While (Len(Fichier) > 0)
 
        If Right(Fichier, 3) = Extension Then
 
            I = I + 1
            ReDim Preserve TableauFichiers(1 To I)
            TableauFichiers(I) = Fichier
 
        End If
 
        Fichier = Dir()
 
    Loop
 
    Fichiers = TableauFichiers()
 
End Function