Copie d'onglets selon critères multiples avec Method AdvancedFilter

[Nikless]

Bonjour le Forum;

Je souhaite effectuer des copies d'onglets modèle en fonction de multiples critères présents sur un onglets sources. Une fois les onglets dupliques, je souhaite pouvoir effectuer la somme dans un onglet Total.
Les onglets de Détails et de Total pourront ensuite être copiés vers un nouveau classeur.

Je décris ci-dessous ce à quoi je suis parvenu et ce vers quoi je voudrais tendre.
Peut-être est-il possible d'optimiser mon code avec des Arrays() et autres bonnes pratiques.

Merci d'avance pour votre aide.


Le code actuel :
1. Duplique les onglets Template_Unit et Template_Total suivant le type des unités situés sur l'onglet Source.
2. Ne me permet pas de faire la somme sur les Onglets Total sauf de manière manuelle en intercalant les onglets entre Start et Stop.
3. Protéger les onglets lors de la fermeture du fichier. --> Problème lorsque plusieurs onglets sont sélectionnés.

L'objectif au lancement de la macro :
1. Dupliquer les unités par Pays et par Responsable suivant leur Type sur le template correspondant (Unit ou Total) --> Possibilité d'utiliser le AdvancedFilter ?
2. Enregistrer les Unités et le Total par Pays et Responsable dans un classeur.
Point particulier : copier le code du module d'origine dans le classeur copié (afin de conserver les formules personnelles dans le nouveau classeur) et protéger le projet VBA.
3. Protéger les onglets lors de la fermeture du fichier.

Sub DupliquerTemplate()

Dim i As Integer
Dim intmax As Integer
Dim code As String
Dim Transco As Worksheet

Set Transco = Sheets("Source")

'Call supOnglets

Application.ScreenUpdating = False

'Besoin de recalculer les formules sur chaque onglet pour MAJ les valeurs
'Application.Calculation = xlCalculationManual


intmax = Transco.[A200].End(xlUp).Row

For i = 2 To intmax
code = Transco.Cells(i, 1)

If Transco.Cells(i, 1).Offset(0, 3) = "Unité" Then
Worksheets("Template_Unit").Copy after:=Sheets(Sheets.Count)
        With ActiveSheet
           
            .Name = code
            .[B1].Value = code
            .Tab.Color = 8
            .Range("A:c").Copy
            .Range("a:c").PasteSpecial xlPasteValues
            .Cells(1, 1).Select
            Application.CutCopyMode = False
            .PageSetup.FitToPagesWide = 1
            .PageSetup.FitToPagesTall = 1
            .Protect "nuage", True, True
        End With
        
        With ActiveWindow
            .ScrollRow = 1
            .ScrollColumn = 1
        End With

Else
Worksheets("Template_Total").Copy after:=Sheets(Sheets.Count)
        With ActiveSheet
           
            .Name = code
            .[B1].Value = code
            .Tab.Color = 18
            .Range("A:c").Copy
            .Cells(1, 1).Select
            Application.CutCopyMode = False
            .PageSetup.FitToPagesWide = 1
            .PageSetup.FitToPagesTall = 1
            .Protect "nuage", True, True
        End With
        
        With ActiveWindow
            .ScrollRow = 1
            .ScrollColumn = 1
        End With

End If

Next i

MsgBox ("Terminé!")

Application.ScreenUpdating = True

End Sub