Autres Regroupement de feuilles

Sub Regroupement_Données()
    Dim Address_Feuilles As String, Compteur As Integer
    For Compteur = 135 To 137
        If Feuille_Existe(CStr(Compteur)) Then
            With Sheets(CStr(Compteur))
                If Sheets("REGROUPEMENT").Range("A6").Value = "" Then
                    If Not .Range("A2").Value = "" Then
                        Address_Feuilles = .Range("A2:J" & .Range("A65536").End(xlUp).Row).Address
                        Sheets("REGROUPEMENT").Range("A5").Range(Address_Feuilles).Value = .Range("A2:J" & .Range("A65536").End(xlUp).Row).Value
                    End If
                Else
                    If Not .Range("A2").Value = "" Then
                        Address_Feuilles = .Range("A2:J" & .Range("A65536").End(xlUp).Row).Address
                        Sheets("REGROUPEMENT").Range("A65536").End(xlUp).Range(Address_Feuilles).Value = .Range("A2:J" & .Range("A65536").End(xlUp).Row).Value
                    End If
                End If
            End With
        Else
            MsgBox "La feuille " & Compteur & " n'existe pas.", vbInformation + vbOKOnly
        End If
    Next Compteur
End Sub
Function Feuille_Existe(ByVal NomFeuille$) As Boolean
    Dim Test_Objet As Worksheet
    On Error GoTo Gere_Erreurs
    Set Test_Objet = ActiveWorkbook.Worksheets(NomFeuille)
    Feuille_Existe = True
    Set Test_Objet = Nothing
Gere_Erreurs:
End Function

Private Sub Worksheet_Activate()
Dim lig&, w As Worksheet
lig = 6 '1ère ligne de destination
Application.ScreenUpdating = False
Rows(lig & ":" & Rows.Count).Delete 'RAZ
For Each w In Worksheets
    If IsNumeric(w.Name) Then 'si valeur numérique
        With w.[A1].CurrentRegion.EntireRow
            If .Rows.Count > 1 Then
                .Rows(2).Resize(.Rows.Count - 1).Copy Rows(lig) 'copier-coller
                lig = lig + .Rows.Count - 1
            End If
        End With
    End If
Next
End Sub

Public Const Feuilles_Exclues = "REGROUPEMENTCréationInformationrésumé "
Sub Regroupement_Données()
    Dim Address_Feuilles As String, Feuille_en_Cours As Worksheet
    For Each Feuille_en_Cours In ThisWorkbook.Worksheets
       If Not UCase(Feuilles_Exclues) Like "*" & UCase(Trim(Feuille_en_Cours.Name)) & "*" Then
            With Feuille_en_Cours
                If Sheets("REGROUPEMENT").Range("A6").Value = "" Then
                    If Not .Range("A2").Value = "" Then
                        Address_Feuilles = .Range("A2:J" & .Range("A65536").End(xlUp).Row).Address
                        Sheets("REGROUPEMENT").Range("A5").Range(Address_Feuilles).Value = .Range("A2:J" & .Range("A65536").End(xlUp).Row).Value
                    End If
                Else
                    If Not .Range("A2").Value = "" Then
                        Address_Feuilles = .Range("A2:J" & .Range("A65536").End(xlUp).Row).Address
                        Sheets("REGROUPEMENT").Range("A65536").End(xlUp).Range(Address_Feuilles).Value = .Range("A2:J" & .Range("A65536").End(xlUp).Row).Value
                    End If
                End If
            End With
         End If
    Next Feuille_en_Cours
End Sub