Macro pour copier plusieurs onglets de plusieurs feuilles

Bonjour,
j'ai une macro que j'ai besoin d'améliorer car je viens de me rendre compte que certains classeurs avaient plusieurs onglets.

du coup je voudrais intégrer dans le code le fait de remonter tous les onglets du classeurs tant que la cellule A4 n'est pas vide.

Sub syntèseClasseurs()
Dim ClasseurRecap As String, ClassImp As String, NomFeuilleImp As String, DerLigRecap As Long, DerLigImp As Long, Pays As Variant, Code As String

Rows("3:" & Cells(Rows.Count, 2).End(xlUp).Row + 1).Delete

' Détermination du classeur récapitulatif
ClasseurRecap = ThisWorkbook.Name
DerLigRecap = Cells(Rows.Count, 2).End(xlUp).Row

' Détermination DernièreLigne
If DerLigRecap <= 2 Then
DerLigRecap = 3
End If

'Set maitre = ActiveWorkbook
Repertoire = ThisWorkbook.Path
ClassImp = Dir(Repertoire & "\*.xls") ' premier fichier
Do While ClassImp <> ""
If ClassImp <> ThisWorkbook.Name Then
Workbooks.Open Filename:=Repertoire & "\" & ClassImp
NomFeuilleImp = Workbooks(ClassImp).ActiveSheet.Name
DerLigImp = Workbooks(ClassImp).Worksheets(NomFeuilleImp).Cells(Rows.Count, 2).End(xlUp).Row
Rows("4:" & DerLigImp).Copy
Pays = Range("A1").Value
Windows(ClasseurRecap).Activate
Rows(DerLigRecap).Select
ActiveSheet.Paste
Range("AA" & DerLigRecap & ":AA" & DerLigRecap + DerLigImp - 4) = Pays
Application.CutCopyMode = False
Windows(ClassImp).Close False
With Worksheets("Table").Range("A1:A" & Worksheets("Table").Cells(Rows.Count, 1).Row)
Set c = .Find(Pays, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
ActiveSheet.Range("AB" & DerLigRecap & ":AB" & DerLigRecap + DerLigImp - 4).Value = c.Offset(0, 1)
ActiveSheet.Range("AC" & DerLigRecap & ":AC" & DerLigRecap + DerLigImp - 4).Value = c.Offset(0, 2)
End If
End With
DerLigRecap = DerLigRecap + DerLigImp - 3
End If
ClassImp = Dir ' fichier suivant
Loop

Range(Cells(3, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 30)).Style = "Style 1"
Columns("A:AD").AutoFit
Rows("1:" & Cells(Rows.Count, 1).End(xlUp).Row).AutoFit

For Each cell In Range("B3:B" & Cells(Rows.Count, 2).End(xlUp).Row)
If cell = "TIT" Then
Code = "G2 TIT"
ElseIf cell = "VI" Then
Code = "G3 VI"
ElseIf cell = "CTR" Then
Code = "G4 CTR"
ElseIf cell = "ADL" Then
Code = "G5 ADL"
Else: Code = ""
End If
Range("AD" & cell.Row) = Code
Next cell

End Sub


merci à ceux qui pourront m'aider
http://www.cjoint.com/c/FDbnFQj2Kxi