Sous-totaux dynamiques VBA

Bonjour à tous,

J'ai créé une macro qui est censée extraire des feuilles de calcul, les sauvegarder sur le bureau tout en assurant un formatage des données via un sous-total.
C'est la mise en place des sous-totaux qui met en évidence les limites de mes connaissances.

En effet, chaque fichier sauvegardé a un nombre de colonnes variables.

Je ne parviens pas à adapter la mise en place du sous-total en fonction des colonnes pour lesquelles la ligne 1 est non vide.

Pour les fichiers dont le nombre de caractères du nom de la feuille de calcul est inférieur à 12 caractères, j'ai besoin que le sous-total se fasse de la colonne F à la dernière colonne non vide.
Si le nombre de caractères excède 12 caractères, le sous-total total doit se faire de la colonne G à la dernière colonne non vide.

Je n'ai pas encore fait la distinction entre les 12 caractères et plus car mes sous-totaux ne s''adaptent pas encore. Le message d'erreur récurrent est l'erreur 1004 "Subtotal method or range class failed" pour ceci :

selectionRange.Subtotal GroupBy:=1, Function:=xlSum, _
                    TotalList:=Application.Transpose(Application.Range(targetSheet.Cells(1, 6), targetSheet.Cells(1, lastCol))), _
                    Replace:=True, PageBreaks:=False, SummaryBelowData:=True

Voici mon code :

Sub extrairefeuille()
    Dim ws As Worksheet
    Dim newwb As Workbook
    Dim savepath As String
    Dim inputyear As String
    Dim lastCol As Long
    Dim lastRow As Long
    Dim firstEmptyCol As Long
    Dim colBB As Long
    Dim targetSheet As Worksheet
    Dim filePath As String

    inputyear = InputBox("Veuillez entrer l'année:", "Année", "2024")
    If inputyear = "" Then
        MsgBox "Pas d'année valide"
        Exit Sub
    End If

    savepath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\XXX\"

    If Dir(savepath, vbDirectory) = "" Then
        MkDir savepath
    End If

    For Each ws In ThisWorkbook.Worksheets
        If Left(ws.Name, 2) = "ZZ" Then
            Set newwb = Workbooks.Add
            Set targetSheet = newwb.Sheets(1)

            lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

            firstEmptyCol = 0
            For i = 1 To lastCol
                If Trim(ws.Cells(1, i).Value) = "" Then
                    firstEmptyCol = i
                    Exit For
                End If
            Next i

            If firstEmptyCol > 0 Then
                colBB = 54
                If firstEmptyCol <= colBB Then
                    ws.Columns(firstEmptyCol & ":" & colBB).Delete
                End If
            End If

            ws.UsedRange.Copy
            targetSheet.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False

            targetSheet.Name = ws.Name

            lastRow = targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).Row

            Set selectionRange = targetSheet.Range("A1", targetSheet.Cells(lastRow, lastCol))

            If lastCol >= 6 Then
                selectionRange.Subtotal GroupBy:=1, Function:=xlSum, _
                    TotalList:=Application.Transpose(Application.Range(targetSheet.Cells(1, 6), targetSheet.Cells(1, lastCol))), _
                    Replace:=True, PageBreaks:=False, SummaryBelowData:=True
            Else
                MsgBox "Pas de données suffisantes à partir de la colonne F pour appliquer les sous-totaux."
            End If

            filePath = savepath & ws.Name & ".xlsx"

            On Error Resume Next
            Kill filePath
            On Error GoTo 0

            newwb.SaveAs filePath

            newwb.Close False
        End If
    Next ws

    MsgBox "Job Done !"
End Sub

Merci d'avance pour votre aide

Voici le fichier demandé

Je me rends bien compte qu'il serait préférable d'utiliser quelque chose comme :

Array(lastCol, 6)

plutôt qu'un objet :

 TotalList:=Application.Transpose(Application.Range(targetSheet.Cells(1, 6), targetSheet.Cells(1, lastCol)))

Mais en pratique ça ne fonctionne pas non plus.

J'ai adapté le fichier en ce sens.

Merci beaucoup pour votre retour !

Si vous avez une piste ou si vous estimez qu'un tel sous-total dynamique n'est pas possible, je suis intéressé par votre opinion/piste.

Par l'intermédiaire d'une simple piste, je tenterai de trouver une solution mais je suis vraiment coincé.

Bon weekend !

Bonjour,

J'ai du mal à comprendre, même en ayant relu 20x. Chez moi la macro s'exécute sans erreur.

Pouvez-vous joindre 2 fichiers des résultats voulus, faits manuellement sur l'exemple que vous avez joint, pour les 2 cas à traiter ?

Si j'ai bien compris, votre problème est que les sous-totaux ne sont pas calculés sur toutes les colonnes des pays, et c'est ça que vous souhaitez changer ? Ie. calculer 1 sous-total par pays et par trimestre ?