VBA renommer les onglets sans doublons

Le 22/10/2022 à 22:58

Bonjour,

J'ai un code qui fonctionne très bien pour renommer chaque onglet d'un classeur à partir d'une cellule.

Le soucis est que dans le cas ou un onglet porte déjà ce nom cela crée une erreur, j'aimerai que le nom soit copié suivi de 1 si c'est le 2eme onglet du meme nom, suivi de 2 pour le 3eme....

Je vous laisse mon code et espère que vous pouvez m'aider.

Sub RenommerTousLesOnglets()
' renommer tous les onglet à partir de A1

    For x = 1 To Sheets.Count

        If Worksheets(x).Range("A1").Value <> "" Then

        Sheets(x).Name = Worksheets(x).Range("A1").Value
        End If
    Next
 End Sub
Le 23/10/2022 à 08:09

Hello,

Comme ça, ça fonctionne mais si ton but est de repartir à 1 à chaque fois il faudra faire autrement

Sub RenommerTousLesOnglets()
' renommer tous les onglet à partir de A1
dim compteur as byte
compteur = 1
    For x = 1 To Sheets.Count

        If Worksheets(x).Range("A1").Value <> "" Then
        on error resume next
        Sheets(x).Name = Worksheets(x).Range("A1").Value
        if Err.number > 0 then 
            Sheets(x).Name = Worksheets(x).Range("A1").Value & compteur
            compteur = compteur + 1
         End If
        on error goto 0
    Next
 End Sub
Le 23/10/2022 à 09:28

bonjour,

comme ceci ?

Sub Renommer()
     Dim Dict, aA, i, sp, Nom
     Set Dict = CreateObject("scripting.dictionary")

     For i = 1 To ThisWorkbook.Worksheets.Count
          With ThisWorkbook.Worksheets(i)
               Nom = .Range("A1").value
               If InStr(1, Nom, vbLf) <> 0 Then MsgBox "Feuille " & i & "   " & .Name & vbLf & "erreur avec vblf dans cellule A1" & vbLf & vbLf & Nom, vbCritical, Nom & " !!!": Exit Sub     'vérification A1 contenant un chr(10) !!!
               .Name = "abcdefghjijklmnopqrst" & i
               If Not Dict.exists(Nom) Then Dict(Nom) = Nom
               Dict(Nom) = Dict(Nom) & vbLf & i
          End With
     Next
     aA = Dict.items

     For i = 0 To UBound(aA)
          sp = Split(aA(i), vbLf)
          For j = 1 To UBound(sp)
               With ThisWorkbook.Worksheets(--sp(j))
                    .Name = IIf(Len(sp(0)) = 0, "(No Name !!!)", sp(0)) & IIf(j > 1, "(" & j - 1 & ")", "")
               End With
          Next
     Next

End Sub
Le 23/10/2022 à 09:36

Hello,

Voici la version complète :

Sub RenomeFeuille()
    Dim ArrTmp() As String
    Dim objDico1 As Object, objDico2 As Object
    Dim varKeys As Variant
    Dim i As Integer, compteur As Integer

    ReDim ArrTmp(1 To Worksheets.Count)
For i = 1 To Worksheets.Count
    ArrTmp(i) = IIf(Worksheets(i).Range("a1").Value <> vbNullString, Worksheets(i).Range("a1").Value, Worksheets(i).Name)
Next i

Set objDico1 = CreateObject("Scripting.Dictionary")
Set objDico2 = CreateObject("Scripting.Dictionary")

For i = LBound(ArrTmp) To UBound(ArrTmp)
    If Not ArrTmp(i) = vbNullString Then
        If objDico1.exists(ArrTmp(i)) Then objDico2.Item(ArrTmp(i)) = ""
        objDico1.Item(ArrTmp(i)) = ""
    End If
Next i

For Each varKeys In objDico2.keys
    compteur = 1
    For i = LBound(ArrTmp) To UBound(ArrTmp)
        If ArrTmp(i) = varKeys Then ArrTmp(i) = ArrTmp(i) & compteur: compteur = compteur + 1
    Next i
Next varKeys

Set objDico1 = Nothing
Set objDico2 = Nothing

For i = 1 To Worksheets.Count
    Worksheets(i).Name = ArrTmp(i)
Next i

End Sub
Le 23/10/2022 à 10:28

@Rag02700

IMHO, vous devez renommer les feuilles avant le dernier boucle, autrement vous risquez d'avoir des noms double.

Le 23/10/2022 à 11:02

Hello,

IMHO, vous devez renommer les feuilles avant le dernier boucle, autrement vous risquez d'avoir des noms double.

J'ai pas bien saisi peux-tu me donner un exemple de cas où j'aurai des doublons ?

Le 23/10/2022 à 11:11

Hello Rag02700, un grand merci ça fonctionne super bien

Le 23/10/2022 à 11:14

bonjour,

13rag02700.xlsm (26.61 Ko)
Le 23/10/2022 à 12:02

Bien vu BsAlv

Voici un correctif :

Sub RenomeFeuille()
    Dim ArrTmp() As String
    Dim objDico1 As Object, objDico2 As Object
    Dim varKeys As Variant
    Dim i As Integer, compteur As Integer

    ReDim ArrTmp(1 To Worksheets.Count)
For i = 1 To Worksheets.Count
    ArrTmp(i) = IIf(Worksheets(i).Range("a1").Value <> vbNullString, Worksheets(i).Range("a1").Value, Worksheets(i).Name)
Next i

Set objDico1 = CreateObject("Scripting.Dictionary")
Set objDico2 = CreateObject("Scripting.Dictionary")

For i = LBound(ArrTmp) To UBound(ArrTmp)
    If Not ArrTmp(i) = vbNullString Then
        If objDico1.exists(ArrTmp(i)) Then objDico2.Item(ArrTmp(i)) = ""
        objDico1.Item(ArrTmp(i)) = ""
    End If
Next i

For Each varKeys In objDico2.keys
    compteur = 1
    For i = LBound(ArrTmp) To UBound(ArrTmp)
        If ArrTmp(i) = varKeys Then ArrTmp(i) = ArrTmp(i) & compteur: compteur = compteur + 1
    Next i
Next varKeys

Set objDico1 = Nothing
Set objDico2 = Nothing

For i = 1 To Worksheets.Count
    On Error Resume Next
    Worksheets(i).Name = ArrTmp(i)
    If Err.Number > 0 Then
        compteur = 255
        While Err.Number > 0
            Err.Clear
            Worksheets(ArrTmp(i)).Name = ArrTmp(i) & compteur
            compteur = compteur + 1
        Wend
        Worksheets(i).Name = ArrTmp(i)
    End If
Next i

End Sub
Le 24/10/2022 à 15:53

Bonjour…

Où est l’erreur avec ta proposition BsAlv *? (un fichier joint en cas de panne)

oups

*et les autres données (while sans fin dans ta dernière proposition Rag02700)

13nom-d-onglets.xlsm (22.09 Ko)

Voir cette discussion !

Le 24/10/2022 à 16:51

bonjour Ordonc, Rag02700, le fil,

la cellule A1 de la première feuille contient "a:" et ":" est un charactère interdit (voir 2ième ligne des points à vérifier du msgbox) pour une feuille, donc effacez le ":".

EDIT : après la lecture de la discussion :

Sub Renommer()
     Dim Dict, aA, i, sp, Nom, b
     Set Dict = CreateObject("scripting.dictionary")

     For i = 1 To ThisWorkbook.Worksheets.Count
          With ThisWorkbook.Worksheets(i)
               Nom = .Range("A1").Value
               If InStr(1, Nom, vbLf) <> 0 Then MsgBox "Feuille " & i & "   " & .Name & vbLf & "erreur avec vblf dans cellule A1" & vbLf & vbLf & Nom, vbCritical, Nom & " !!!": Exit Sub     'vérification A1 contenant un chr(10) !!!
               .Name = "abcdefghjijklmnopqrst" & i
               If Not Dict.exists(Nom) Then Dict(Nom) = Nom
               Dict(Nom) = Dict(Nom) & vbLf & i
          End With
     Next
     aA = Dict.items

     On Error Resume Next
     ptr = 0
     For i = 0 To UBound(aA)
          sp = Split(aA(i), vbLf)
          For j = 1 To UBound(sp)
               With ThisWorkbook.Worksheets(--sp(j))
                    .Name = IIf(Len(sp(0)) = 0, "(No Name !!!)", sp(0)) & IIf(j > 1, "(" & j - 1 & ")", "")
                    If Err.Number > 0 Then
                         b = True
                         ptr = ptr + 1
                         .Name = "OUPS_" & ptr
                         .Tab.Color = 255
                         Err.Clear
                    End If
               End With
          Next
     Next
    On Error GoTo 0

     If b Then MsgBox "Il y a " & ptr & " feuille(s) problématique(s)"

End Sub
Le 24/10/2022 à 17:11

Bonjour messieurs,

Désolé par avance, je n'ai pas vraiment suivi le sujet,
mais pourquoi sortir la grosse artillerie pour renommer des onglets 

Sub RenommerTousLesOnglets()
  Dim Sht As Worksheet, NomTmp As String, Inc As Integer
  For Each Sht In ThisWorkbook.Sheets
    If Sht.Range("A1").Value <> "" Then
      Inc = 0: NomTmp = Sht.Range("A1").Value
      Do While FeuilExiste(NomTmp)
        Inc = Inc + 1
        NomTmp = Sht.Range("A1").Value & Inc
      Loop
      Sht.Name = NomTmp
    End If
 Next
End Sub

Function FeuilExiste(sNom As String)
  Dim Test
  On Error Resume Next
  Test = Sheets(sNom).Range("A1").Value
  If Err.Number = 0 Then FeuilExiste = True Else FeuilExiste = False: Err.Clear
  On Error GoTo 0
End Function

A+

Le 24/10/2022 à 17:21

Bonjour à tous,

@Bruno, c'est bien connu, + tu en as une grosse + tu es efficace

Le 24/10/2022 à 17:34

@Bruno, ce n'est pas la grosse artellerie et c'est pour être sûr qu'on a une série ascendante des feuilles avec le même nom. Avec votre méthode, vous n'aurez jamais cette certitude.

Le 24/10/2022 à 18:05

@ Ordonc,

image
Le 24/10/2022 à 18:22

Re,

BsAlv a écrit :

@Bruno, ce n'est pas la grosse artellerie

et c'est pour être sûr qu'on a une série ascendante des feuilles avec le même nom. Avec votre méthode, vous n'aurez jamais cette certitude.

Ah bon non sérieux

Pour ma méthode, il faudra me prouver le contraire...

Allez bonne soirée

Le 24/10/2022 à 18:44

@Rag2700

Rag02700 a écrit :

Bonjour à tous,

@Bruno, c'est bien connu, + tu en as une grosse + tu es efficace

Je ne parlerai pas ici de ce que m'a dis ta femme à ce sujet

Le 24/10/2022 à 19:54

Pour ma méthode, il faudra me prouver le contraire...

le fichier pour Rag02700 de hier 11:14 avec votre macro ajoutée et un bouton sur la première feuille. Poussez le bouton plusieurs fois et ... les noms de feuilles changent tout le temps, allez ???, mais jamais avec une série ascendante.

Ce n'est pas la grosse artellerie, c'est la guerre avec des élastiques.

9rag02700.xlsm (32.29 Ko)
Le 25/10/2022 à 18:13

Bonsoir BsAlv,

Ce que je vois c'est un belle mauvaise fois de ta part, je trouve

C'était un code donné comme ça vite fait, il manquait juste un test

13ordonc-nom-onglets.xlsm (21.80 Ko)

Ceci dit, tu sembles te complaire à donner des codes qui rendent les gens dépendants
et que seuls quelques érudits comme toi peuvent arriver à comprendre

Pour ma part, je préfère nettement me rendre accessible et compréhensible de tous

Bref je clôturerais là le sujet, les joutes verbales n'intéressent personne.

Rechercher des sujets similaires à "vba renommer onglets doublons"