Dupliquer le nom d'un onglet en incrémentant un nombre

**claire9999** · 07/11/2014, 09h33

Bonjour tout le monde,
j'ai cette boucle qui permet d'incrémenter un nombre à un onglet de même nom que son précédant

Code :

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

1
2
3
4
5
6
7
 
For Each Onglet In ThisWorkbook.Worksheets
        If Onglet.Name = Nom_Feuille Then
        Indice = Indice + 1
        Nom_Feuille = Nom_Feuille & "(" & Indice & ")"
        End If
        Next Onglet

le souci avec cette boucle c'est quand on ajoute plusieurs feuilles de même nom le résultat sera défini comme suit:
Feuille (1), Feuille (1)(2), Feuille (1)(2)(3).....
Y a-t-il une solution afin qu'elle incrémente directement dans la même parenthèse genre
Feuille(1), Feuille(2), Feuille (3).....

**gFZT82** · 07/11/2014, 10h08

Bonjour,

le souci avec cette boucle c'est quand on ajoute plusieurs feuilles de même nom

Je suis curieux de savoir comment tu procèdes pour ajouter plusieurs feuilles de même nom

Cordialement.

**vinc_bilb** · 07/11/2014, 10h42

Bonjour,

Proposition + une fonction qui pourrait vous être utile (permet de tester si une worksheet existe déjà et de la créer sinon, avec ou sans confirmation)
en passant par le split .... ça marche bien

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
 
Sub Create_NewWS()
 
Dim Wsh As Worksheet, ActWsh As Worksheet
Dim ActWsN As String, NewWsN As String
Dim CurWsA As Variant
Dim WshInd As Integer
 
Set ActWsh = ThisWorkbook.Worksheets(1)
ActWsN = ActWsh.Name
WshInd = 0
 
For Each Wsh In ThisWorkbook.Worksheets
 
    If Wsh.Name = ActWsN Then
        WshInd = WshInd + 1
 
        CurWsA = Split(Wsh.Name, "(")
        If UBound(CurWsA, 1) > 0 Then
 
            Debug.Print CInt(Left(CurWsA(UBound(CurWsA, 1)), Len(CurWsA(UBound(CurWsA, 1))) - 1))
 
            WshInd = CInt(Left(CurWsA(UBound(CurWsA, 1)), Len(CurWsA(UBound(CurWsA, 1))) - 1)) + 1
 
        End If
        ActWsN = ActWsN & "(" & WshInd & ")"
    End If
 
Next Wsh
End Sub
 
Function Exist_Wsh(Wbk As Workbook, WshName As String, Optional CreateSh As Boolean = False, Optional Prompt_creat As Boolean = False, Optional TabCol As Variant = vbCyan) As Boolean
'=============================================================================
' Check if a sheet exists by an access and create it if not (optional)
 
    Funcname = "Exist_Wsh"
 
    Dim Msgansw As String, Wsh As Worksheet
 
    If IsMissing(Wbk) Then Set Wbk = ActiveWorkbook
 
    On Error GoTo Err_notexist
 
        ' Set the default values
    Exist_Wsh = False
 
        ' Test by access to the sheet, return true if succeeded, or test the Error 9
    If Wbk.Worksheets(WshName).Range("A1").Address <> "" Then Exist_Wsh = True
 
Err_notexist:
 
        ' Expected Error raised when accessing to a not existing sheet
    If Err.Number = 9 Then
 
        Err.Clear
 
        Msgansw = vbOK
 
            ' Create if CreateSh = True with or without user confirmation depending on Prompt_creat
        If CreateSh = True Then
 
            If Prompt_creat = True Then
                Msgansw = MsgBox("The sheet " & WshName & " doesn't exist" & " in workbbok " & Wbk.Name & vbCrLf & _
                    "Would you like to create it?", vbExclamation + vbOKCancel, Funcname)
            End If
 
                ' Create it if not existing depending on users inputs or option
            If Msgansw <> vbCancel Or Prompt_creat = False Then
 
                Set Wsh = Wbk.Worksheets.Add(After:=Wbk.Worsheets(Wbk.Worksheets.Count))
                Wsh.Name = WshName
                Debug.Print VarType(Wsh.Tab.Color)
                Wsh.Tab.Color = TabCol
 
                    ' Test by access to the sheet, return true if succeeded
                If Wsh.Range("A1").Address <> "" Then Exist_Wsh = True
 
            End If
 
        End If
 
        Err.Clear
 
            ' Return false if another error
    Else:
        If Err.Number > 0 Then
            MsgBox "Error: " & Err.Number & vbCrLf & Err.Description, vbCritical, Funcname
            Exist_Wsh = False
            Err.Clear
        End If
    End If
End Function

Bonne journée

**kiki29** · 07/11/2014, 12h15

Salut, à tester :

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
Option Explicit
 
Function RenommerFeuille(sNomFeuille As String) As String
Dim sNouveauNom As String, iExt As Long
Dim i As Long, Pos As Long, sPre As String
 
    If SheetExists(sNomFeuille) = True Then
        sNouveauNom = sNomFeuille
        Pos = InStr(sNomFeuille, "(")
        iExt = Len(sNomFeuille) - Pos + 1
        If Pos > 0 Then
            sPre = Left$(sNomFeuille, Len(sNomFeuille) - iExt)
        Else
            sPre = sNomFeuille
        End If
 
        i = 0
        While SheetExists(sNouveauNom) = True
            i = i + 1
            sNouveauNom = sPre & Chr(40) & i & Chr(41)
        Wend
        sNomFeuille = sNouveauNom
    End If
 
    RenommerFeuille = sNomFeuille
End Function
 
Private Function SheetExists(SheetName As String) As Boolean
    On Error Resume Next
    SheetExists = CBool(Len(ThisWorkbook.Sheets(SheetName).Name))
    On Error GoTo 0
End Function

A toi de l'intégrer dans ta procédure d'ajout de feuilles/graphes
bref qqch comme ceci :

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
Sub AjoutFeuille()
Dim sNom As String
Dim sFeuille As String
    sFeuille = "Feuille (1)"
    Sheets.Add
    sNom = RenommerFeuille(sFeuille)
    ActiveSheet.Name = sNom
    Tri
End Sub
 
Private Sub Tri()
Dim cpt As Long
Dim sMin As String
Dim i As Long
    Application.ScreenUpdating = False
    cpt = Sheets.Count
    sMin = LCase$(Sheets(1).Name)
    While cpt > 0
        For i = 2 To cpt
            If LCase$(Sheets(i).Name) < sMin Then sMin = LCase$(Sheets(i).Name)
        Next i
        Sheets(sMin).Move After:=Sheets(Sheets.Count)
        sMin = LCase$(Sheets(1).Name)
        cpt = cpt - 1
    Wend
    Application.ScreenUpdating = True
End Sub

Comme le tri est Alphabétique et si le nombre de feuilles > 9 on pourra adapter ainsi ( ce qui laisse de la marge ... ) :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
Sub AjoutFeuille()
    .....
    sFeuille = "Feuille (001)"
    .....
End Sub

Function RenommerFeuille(sNomFeuille As String) As String
    .....
            sNouveauNom = sPre & Chr(40) & Format(i, "000") & Chr(41)
    .....
End Function

**claire9999** · 12/11/2014, 08h56

Bonjour tout le monde,
je vous remercie tous pour votre aide,
vinc_bilb j'ai essayé ton code mais le même problème ce reproduit, càd il ajoute l'indice dans une autre parenthèse : Feuille (1) Feuille(1)(2)...
par contre j'ai testé la fonction de kiki29 et ça fonctionne très bien.
c'est juste que j'ai une petite question sans vous déranger bien sur.
j'ai un problème sur les majuscules en comparants deux feuilles de même nom et l'une en majuscule et l'autre en minuscule il prendra pas en compte la fonction pour renommer la feuille ex (FEUILLE et feuille) du coup l'ajout de la feuille est impossible.

Code :

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

1
2
3
4
5
6
 
 For Each Onglet In ThisWorkbook.Worksheets
         If Onglet.Name = Nom_Feuille Then
         Nom_Feuille = RenommerFeuille(Nom_Feuille) ' fonction de renommage 
         End If
    Next Onglet

Merci de votre aide

**SfJ5Rpw8** · 12/11/2014, 09h02

Bonjour,

plusieurs solutions :

soit tu compare tes 2 chaines après les avoir passé en minuscule ou majuscule (lcase ou ucase

)

soit tu utilise la fonction StrComp

...

**kiki29** · 12/11/2014, 09h04

Salut, je te suggère d'essayer ceci

Code :

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

sNom = Application.WorksheetFunction.Proper(RenommerFeuille(sFeuille))

sinon il y a UCase$ ou LCase$

**claire9999** · 12/11/2014, 09h12

normalement j'ai trouvé une astuce qui à l'air de fonctionner correctement.
au début de la macro j'ai ajouté

Code :

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

1
2
 
Option Compare Text

Merci encore une fois

**kiki29** · 12/11/2014, 10h02

re, un détail : pour le test d'existence de la feuille il y a plus concis

Code :

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

1
2
3
4
5
Private Function ExistenceFeuille(sNomFeuille As String) As Boolean
    On Error Resume Next
    ExistenceFeuille = Sheets(sNomFeuille).Name <> ""
    Err.Clear
End Function

**Marc-L** · 12/11/2014, 14h44

Bonjour, bonjour !

Pour l'existence d'une feuille, il y a déjà la fonction de feuille de calculs ESTREF !

Une seule ligne de code nécessaire ! Voir donc dans cette discussion …

__________________________________________________________________________________________

Merci de cliquer sur

pour chaque message ayant aidé puis sur

pour clore cette discussion …

Dupliquer le nom d'un onglet en incrémentant un nombre

Macros et VBA Excel

Discussions similaires

Partager

Partager