Copier un classeur ouvert dans un sous-répertoire et nommer en fonction

Bonjour à tous,

J'essaie de mettre en place une macro qui permettra de copier mon classeur ouvert dans tous les sous-répertoire d'un répertoire et de les nommer en fonction du nom de ce sous-répertoire.

Je dispose actuellement d'une macro dans un classeur nommé HMO S qui me permet de copier ces classeurs dans un seul classeur que je colle dans chaque sous-répertoire nommé "Semaine 01" "Semaine 02" ainsi de suite jusque "Semaine 52" et tous ces sous-répertoires sont dans mon répertoire "Année 2021". Tous ces sous-répertoires contiennent des classeurs nommé en fonction de la date et de l'équipe '20210104A" "20210104B" "20210104C" donc une déclaration par jour et par équipe ce qui fait à peu près 20 classeurs à la semaine et plus de 900 à l'année. Il n'y a qu'une seule feuille par classeur.

Voici la macro de "HMO S" qui a été faite par Pedro22 que je remercie par ailleurs.

Sub Macrote()
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim F As String 'déclare la varaible F (Fichier)
Dim CS As Workbook 'définit la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet)
Dim J As String ' déclare la variable J
Dim CD As Worksheet 'déclare la varaible CD (Classeur Destinsation)

Application.DisplayAlerts = False 'Désactive les messages d'alerte
'Application.ScreenUpdating = False 'Désactive l'affichage
Application.Calculation = xlCalculationManual 'Désactive le recalcul auto des formules

On Error Resume Next 'En cas d'erreur, passe à l'instruction suivante
With ThisWorkbook 'Tout ce qui commence par un "." s'y rapporte
    CA = .Path & "\" 'définit la chemin d'acces du dossier des fichiers source
    F = Dir(CA & "*.xlsx") 'définit le premier fichier F avec extension .xlsx ayant CA comme chemin d'accès (extension à adapter)
    Do While Len(F) > 0
        Set CS = Workbooks.Open(CA & F, 0) 'ouvre le fichier F
        Set OS = CS.Sheets(1) 'définit l'onglet OS
        J = Replace(CS.Name, ".xlsx", "") 'Récupère le nom du classeur seul
        If J Like "########?" Then 'Si le nom correspond au format désiré (date + lettre)
            J = Choose(Weekday(DateSerial(Mid(J, 1, 4), Mid(J, 5, 2), Mid(J, 7, 2)), vbMonday), "Lun ", "Mar ", "Mer ", "Jeu ", "Ven ", "Sam ", "Dim ") & UCase(Mid(J, 9, 1)) 'Identifie le nom de la feuille de destination
            OS.Range("A1:AK50").Copy 'Copie les données
            .Sheets(J).Range("A1").PasteSpecial xlPasteValues
            .Sheets("Model").Cells.Copy 'Applique le format modèle
            .Sheets(J).Range("A1").PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
        End If
        CS.Close False 'Ferme le fichier source
        F = Dir() 'définit le prochain fichier F
    Loop 'boucle
End With
End Sub 

Ce que je voudrais:

-Copier ce fichier HMO S dans chaque sous-répertoire de mon répertoire "C:\Document\Plannif\"

-Nommer ce classeur en fonction du sous répertoire qui se nomme Semaine 01 et j'aimerais obtenir HMO S1; Semaine 01 => HMO S2 ainsi de suite.

-Ensuite ouvrir ce classeur dans chaque sous-répertoire un par un et excuter la macro nommer "Macrote"

-Puis enregistrer ce classeur dans ce sous-répertoire et dans dans un autre répertoire "C:\Document\Plannif\Semaine\"

Je vous mets les fichiers nécessaire.

Je vous remercie d'avance.