Regrouper plusieurs feuilles

Bonjour à tous

J'ai actualisé mon fichier en ajoutant 52 feuilles, je suis bloqué au niveau de la mise à jour du code.

Merci de vérifier et corriger l'erreur.

Bonjour,

Essaie avec cette nouvelle procédure.

Cdlt.

Option Explicit
'Option Private Module

Public Sub MergedWorksheets2()
Dim wb As Workbook
Dim ws As Worksheet, wsData As Worksheet
Dim tbl As ListObject, tblMain As ListObject
Dim rStart As Range

    Application.ScreenUpdating = False
    Set wb = ActiveWorkbook
    Set wsData = wb.Worksheets("Résumé")

    With wsData
        Set tblMain = .ListObjects(1)
        With tblMain
            If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
            Set rStart = .InsertRowRange.Cells(1)
        End With
    End With

    For Each ws In wb.Worksheets
        Select Case ws.Name
            Case "Accueil", "Listes", "Résumé", "TCD"
                '
            Case Else
                Set tbl = ws.ListObjects(1)
                tbl.DataBodyRange.Copy
                rStart.PasteSpecial xlPasteValues
                Application.CutCopyMode = False
                Set rStart = tblMain.HeaderRowRange.Cells(1). _
                             Offset(tblMain.ListRows.Count + 1)
        End Select
    Next ws

    wsData.Activate

    MsgBox "Mise à jour effectuée", vbOKOnly + vbInformation, _
           "Consolidation annuelle"

    Set rStart = Nothing
    Set tbl = Nothing: Set tblMain = Nothing
    Set wsData = Nothing
    Set wb = Nothing

End Sub

Merci toujours Jean Eric pour ton effort considérable