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