XL 2021 Insérer le nom de chaque feuille dans un tableau récap

[Driff042]

Bonjour à toutes et tous,
J'ai recherché en vain, sur le forum, pour faire remonter le nom de chaque feuille créée dans un tableau récap mis en forme.

Quelqu'un pourrait m'aider SVP ?
bonne journée

 

[AtTheOne]

Re,
@vgendron je te confirme ma remarque pour les 2 versions dont je dispose voir le gif ci-dessous :

A bientôt

 

[AtTheOne]

il y a une option (directement dans la table???) qui permet de désactiver cette propagation..

Je ne connais pas, mise à part dans les options d'excel :

mais ce n'est pas lié au classeur, c'est gênant pour les autres classeurs. A moins dans la macro de déactiver avant d'écrire les formules et de réactiver juste après ...
A plus

 

[AtTheOne]

suite :
@vgendron ta macro deviendrait :

Sub listing()

Dim ws As Worksheet, mode As Boolean
mode = Application.AutoCorrect.AutoFillFormulasInLists
Application.AutoCorrect.AutoFillFormulasInLists = False
With Sheets("Bilan").ListObjects("t_Bilan")
    .DataBodyRange.Delete
   
    For Each ws In ActiveWorkbook.Sheets
        If ws.Name <> "Bilan" Then
            NomTab = ws.ListObjects(1).Name
           
            .ListRows.Add
            LastLine = .ListRows.Count
            .DataBodyRange(LastLine, 1) = ws.Name
            formule1 = "=" & NomTab & "[[#Totals],[Total]]"
            formule2 = "=" & NomTab & "[[#Totals],[Montant]]"
            .DataBodyRange(LastLine, 2).Formula = formule1
            .DataBodyRange(LastLine, 4).Formula = formule2
        End If
    Next ws
End With
Application.AutoCorrect.AutoFillFormulasInLists = mode

End Sub

 

[AtTheOne]

suite ...
Autre point, si listrows.count = 0 (cas où l'on a supprimer toutes les lignes du TS avant de lancer la macro), DataBodyRange n'est pas défini et son utilisation déclenche une erreur ..

 

[Driff042]

Bonjour,
Pas de retour sur ma proposition ?
Cordialement

Bonjour goube,
désolé, je suis en mode vacances et pas très assidu, je regarde et vous fais un retour sans faute.

 

[Driff042]

Bonsoir à toutes & à tous, bonsoir @Driff042, @vgendron , @goube,
en regardant les propositions formulées je me suis rendu compte que j'avais oublié de trier, c'est chose faite maintenant :

Sub Lister_Feuilles()
     Dim WSh As Worksheet, DC As Object
     Dim tablo(), Lgn1(), nb_Cols%, nb_Lgns%
   
     'Mémorisation des formules de la 1ère ligne
     Lgn1 = Application.[Tb_Bilan].Rows(1).FormulaLocal
     'Mettre des constantes dans la 1ère ligne pour éviter l'extention automatique des formules dans le tabeau
     [Tb_Bilan].Rows(1).Value = [Tb_Bilan].Rows(1).Value
   
     'Tableau Actuel (pour ne pas effacer les données déjà saisies) (transposer pour utiliser REDIM)
     tablo = Application.Transpose([Tb_Bilan].FormulaLocal)
     nb_Cols = UBound(tablo, 1)
     nb_Lgns = UBound(tablo, 2)
   
     'Feuilles déjà listées dans le tableau
     Set DC = CreateObject("Scripting.dictionary")
     For i = 1 To UBound(tablo, 2)
          DC(tablo(1, i)) = i
     Next
   
     'Collecte des nouvelles feuilles
     '(hors feuilles "Bilan", feuilles déjà collectée, feuille sans ou avec plusieurs Listobject)
     For Each WSh In ThisWorkbook.Worksheets
          NomSh = WSh.Name
          If NomSh <> "Bilan" And Not DC.exists(NomSh) And WSh.ListObjects.Count = 1 Then
               nb_Lgns = nb_Lgns + 1: ReDim Preserve tablo(1 To nb_Cols, 1 To nb_Lgns)
               NomLO = WSh.ListObjects(1).Name
               tablo(1, nb_Lgns) = WSh.Name
               tablo(2, nb_Lgns) = "=" & NomLO & "[[#Totaux];[Total]]"
               tablo(4, nb_Lgns) = "=" & NomLO & "[[#Totaux];[Montant]]"
          End If
     Next
   
     'Redimensionnement du tableau
     [Tb_Bilan].ListObject.Resize [Tb_Bilan].ListObject.Range.Resize(nb_Lgns + 2) ' +2 = lignes entête et ligne total
   
     'Collage des formules
     [Tb_Bilan].FormulaLocal = Application.Transpose(tablo)
     'Restitution des formule de la 1ère ligne
     [Tb_Bilan].Rows(1).FormulaLocal = Lgn1
     'Suppression de la 1ère ligne si elle était vide
     If [Tb_Bilan].Cells(1, 1) = "" Then [Tb_Bilan].ListObject.ListRows(1).Delete
   
     With [Tb_Bilan].ListObject.Sort
          .SortFields.Clear
          .SortFields.Add Key:=[tb_bilan[Projet]], DataOption:=xlSortTextAsNumbers
          .Header = xlYes
          .Apply
     End With
   
End Sub

Voir le fichier joint
À bientôt (du moins j'espère !)

Bonsoir à tous et merci pour vos travaux,
Désolé pour cette réponse tardive, mais, je viens de tester ce fichier, c'est parfait pour moi, pas de bug et il met bien à jour la liste existante avec les nouveaux onglets.

 

[Driff042]

Bonjour goube,
désolé, je suis en mode vacances et pas très assidu, je regarde et vous fais un retour sans faute.

Bonsoir Goube,
promis je regarde demain ta proposition.