Structuration du code pour liste dynamique de dossiers

Bonjour à tous,

Je dois recréer chaque année la même structure de dossiers pour les permanences de Week-End du service des sports (donc 54 dossiers environ).

1 dossier par WE nommé : SEM 01 - 06 & 07 Janvier Puis : SEM 02 - 13 & 14 Janvier etc…

Je dois ensuite copier 4 classeurs dans chaque dossier et j’aimerai que certaines cellules de ces classeurs soient alimentées automatiquement (Date de Samedi, Nom de l’Agent, N° De semaine) ainsi que le nom du 4eme classeur (13 & 14 octobre par exemple… mais avec les bonnes dates)

J’ai donc établi une liste dynamique des dates de samedis en fonction de l’année choisie (cellule A1 du classeur Samdim joint). J’en déduis le N° de Semaine puis je crée le nom de mon dossier (texte) et j’ajoute le nom de l’agent d’astreinte.

J’ai ensuite, en tâtonnant, réussi un début de fonction avec une boucle qui crée l’ensemble de mes dossiers avec le nom voulu.

J’ai réussi à copier un classeur dans chaque dossier mais je pense que la méthode n’est pas « propre » tout comme ma tentative de passer une variable avec la date du Samedi (Date_Samedi) aux classeurs copiés…

Je suis un peu beaucoup perdu dans les set, select, activate et autres joyeuseries de VBA que je découvre à petit pas et j’aurai besoin d’être guidé dans la façon de structurer tout cela de manière correcte, efficace et relativement « propre ».

En remerciant tous ceux qui vont se pencher sur ma demande et me dire si je suis dans la bonne direction.

Bonjour,

en B3, tu peux simplifier

=DATE(A1;1;1)-JOURSEM(DATE(A1;1;1))+7

pour le code, il est court c'est un gage de maintenabilité, mais indente correctement celui-ci pour une lecture plus aisée.

Sub Creation_Repertoires_WE()

Dim FichierOriginal As String
Dim FichierCopie As String
Dim Date_Samedi As Date

    FichierOriginal = "C:\Users\Bertrand\Desktop\TestRep2\DT_FCRY_RS_RUGBY.xls"
    On Error Resume Next
    i = 3
    While Cells(i, 4).Value <> ""
        MkDir ActiveWorkbook.Path & "\" & Cells(i, 4).Value
        Date_Samedi = Cells(i, 2).Value
        FichierCopie = "C:\Users\Bertrand\Desktop\TestRep2\" & Cells(i, 4).Value & "\DT_FCRY_RS_RUGBY.xls"
        FileCopy FichierOriginal, FichierCopie
        Workbooks.Open Filename:= _
            "C:\Users\Bertrand\Desktop\TestRep2\" & Cells(i, 4).Value & "\DT_FCRY_RS_RUGBY.xls"
            Range("B13").Value = Date_Samedi
        ActiveWorkbook.Save
        ActiveWorkbook.Close
        i = i + 1
    Wend

End Sub

D'abord un premier grand merci !

La simplification en B3, forcement ça tue… j’étais vraiment fier de ma formule !

Petit souci quand même avant que je me lance pour étendre la fonction en copiant les 3 autres fichiers dans chaque répertoire...

Range("B13").Value = Date_Samedi

se fait dans le classeur Samdim.xslx au lieu de DT_FCRY_RS_Rugby.xslx et plante la fonction.

J'ai donc remplacé par :

Workbooks("DT_FCRY_RS_RUGBY.xlsx").Sheets("Samedi").Range("B13").Value = Date_Samedi

Là ça fonctionne ...mais la copie du fichier dans chaque répertoire est très longue par rapport à la création des répertoires... est-ce Normal... Si je rajoute dans la boucle les autres fichiers et variables j'ai l'impression que ça va ramer dur!

Est-ce obligatoire d'ouvrir et fermer le classeur pour modifier la cellule B13?

zenos a écrit :

Là ça fonctionne ...mais la copie du fichier dans chaque répertoire est très longue par rapport à la création des répertoires... est-ce Normal... Si je rajoute dans la boucle les autres fichiers et variables j'ai l'impression que ça va ramer dur!

Est-ce obligatoire d'ouvrir et fermer le classeur pour modifier la cellule B13?

On peut lire une valeur sans ouvrir le fichier, mais on ne peut pas la modifier sans l'ouvrir ! donc si ça rame ... faut prendre une pause-café !

Vive excel-pratique Vive le forum et Vive Steelson !

Ca fonctionne à merveille. Au cas ou çà servirait à quelqu'un je mets la version actuelle.

Sub Creation_Repertoires_WE()

Dim FichierOriginal As String
Dim FichierCopie As String
Dim Date_Samedi As Date
Dim Agent As String
Dim Num_Semaine As String
Dim Titre_Classeur As String

Application.ScreenUpdating = False

    On Error Resume Next
    i = 3
    While Cells(i, 4).Value <> ""
        MkDir ActiveWorkbook.Path & "\" & Cells(i, 4).Value

        Date_Samedi = Cells(i, 2).Value
        Agent = Cells(i, 6).Value
        Num_Semaine = Cells(i, 3).Value

        FichierOriginal = "C:\Users\Bertrand\Desktop\TestRep3\DT_FCRY_RS_RUGBY.xlsx"
        FichierCopie = "C:\Users\Bertrand\Desktop\TestRep3\" & Cells(i, 4).Value & "\DT_FCRY_RS_RUGBY.xlsx"
        FileCopy FichierOriginal, FichierCopie

        Workbooks.Open Filename:= _
            "C:\Users\Bertrand\Desktop\TestRep3\" & Cells(i, 4).Value & "\DT_FCRY_RS_RUGBY.xlsx"
            Workbooks("DT_FCRY_RS_RUGBY.xlsx").Sheets("Samedi").Range("B13").Value = Date_Samedi
            Workbooks("DT_FCRY_RS_RUGBY.xlsx").Sheets("Samedi").Range("B2").Value = "week-end n°" & Num_Semaine
            Workbooks("DT_FCRY_RS_RUGBY.xlsx").Sheets("Samedi").Range("D6").Value = Agent

        Workbooks("DT_FCRY_RS_RUGBY.xlsx").Close True

        FichierOriginal = "C:\Users\Bertrand\Desktop\TestRep3\DT_RS_BASKET.xlsx"
        FichierCopie = "C:\Users\Bertrand\Desktop\TestRep3\" & Cells(i, 4).Value & "\DT_RS_BASKET.xlsx"
        FileCopy FichierOriginal, FichierCopie

        Workbooks.Open Filename:= _
            "C:\Users\Bertrand\Desktop\TestRep3\" & Cells(i, 4).Value & "\DT_RS_BASKET.xlsx"
            Workbooks("DT_RS_BASKET.xlsx").Sheets("01").Range("B13").Value = Date_Samedi
            Workbooks("DT_RS_BASKET.xlsx").Sheets("01").Range("B2").Value = "week-end n°" & Num_Semaine
            Workbooks("DT_RS_BASKET.xlsx").Sheets("01").Range("D6").Value = Agent

        Workbooks("DT_RS_BASKET.xlsx").Close True

        FichierOriginal = "C:\Users\Bertrand\Desktop\TestRep3\DT_RS_HAND_RS_VOLLEY.xlsx"
        FichierCopie = "C:\Users\Bertrand\Desktop\TestRep3\" & Cells(i, 4).Value & "\DT_RS_HAND_RS_VOLLEY.xlsx"
        FileCopy FichierOriginal, FichierCopie

        Workbooks.Open Filename:= _
            "C:\Users\Bertrand\Desktop\TestRep3\" & Cells(i, 4).Value & "\DT_RS_HAND_RS_VOLLEY.xlsx"
            Workbooks("DT_RS_HAND_RS_VOLLEY.xlsx").Sheets("01").Range("B13").Value = Date_Samedi
            Workbooks("DT_RS_HAND_RS_VOLLEY.xlsx").Sheets("01").Range("B2").Value = "week-end n°" & Num_Semaine
            Workbooks("DT_RS_HAND_RS_VOLLEY.xlsx").Sheets("01").Range("D6").Value = Agent

        Workbooks("DT_RS_HAND_RS_VOLLEY.xlsx").Close True

        FichierOriginal = "C:\Users\Bertrand\Desktop\TestRep3\Planning.xlsx"
        FichierCopie = "C:\Users\Bertrand\Desktop\TestRep3\" & Cells(i, 4).Value & "\" & Cells(i, 5).Value & ".xlsx"
        FileCopy FichierOriginal, FichierCopie

        i = i + 1

    Wend

    Application.ScreenUpdating = True

End Sub
    

Je vais voir si des améliorations sont possibles car je me suis rendu compte qu'en déplaçant le fichier sur un autre ordinateur, il faut modifier tous les chemins pour que cela fonctionne... Question : peut-on utiliser des chemins relatifs ?

En tout cas j'ai appris plein de choses. Grand merci à Steelson pour son aide!