Option Explicit
Sub Prepare()
Dim Agence As Variant
Dim Agence_Initiale As String
Dim Agence_Trouvée As Range
Dim Data As Range
Dim File As String
Dim Dossier As String
Dim Modele As Worksheet
Dim DerRow As Long
Dim DerCol As Long
Application.ScreenUpdating = False
Set Modele = Worksheets("Vêtements de Travail")
Dossier = ThisWorkbook.Path & "\"
' Détermination de la plage de données de "Forms"
With Worksheets("Forms")
DerRow = .Cells(.Rows.Count, "C").End(xlUp).Row
DerCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set Data = .Range("A1", .Cells(DerRow, DerCol))
End With
For Each Agence In Get_Agences(Data.Columns("C"))
' détermination du fichier à créer et destruction de celui-ci s'il existe
File = Agence & " Commande " & Format(Date, "dd_mm_yyyy") & ".xlsx"
If Dir(Dossier & File) <> "" Then Kill Dossier & File
' On va chercher chaque ligne de l'agence en cours
Set Agence_Trouvée = Data.Columns("C").Find(Agence, , xlValues, xlWhole)
Agence_Initiale = ""
Do While Not Agence_Trouvée Is Nothing
If Agence_Initiale = "" Then
' première ligne trouvée
Agence_Initiale = Agence_Trouvée
Modele.Copy ' On duplique la feuille dans un nouveau classeur
ActiveWorkbook.SaveAs Filename:=Dossier & File
Else
Modele.Copy ActiveSheet ' On duplique la feuille avant la feuille active
End If
With ActiveSheet ' On renseigne les champs de la commande
.[Service] = Agence
.[DateCommande] = Format(Date, "dd/mm/yyyy")
.[Nom] = Data.Cells(Agence_Trouvée.Row, "A")
.[PréNom] = Data.Cells(Agence_Trouvée.Row, "B")
.Name = .[Nom] & " " & .[PréNom] ' Nom de la feuille
' -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' ce sera là où les vêtements commandés
' devront être renseignés
' -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
End With
Set Agence_Trouvée = Data.Columns("C").FindNext(Agence_Trouvée)
If Agence_Trouvée = Agence_Initiale Then
Set Agence_Trouvée = Nothing
ActiveWorkbook.Close SaveChanges:=True
End If
Loop
Next
End Sub
Function Get_Agences(Data As Range)
' Table des agences sans doublons
Dim Arl As Object
Dim Cel As Range
Set Arl = CreateObject("System.Collections.ArrayList")
For Each Cel In Data.Offset(1).Cells.Resize(Data.Rows.Count - 1)
Select Case True
Case Cel = ""
Case Arl.Contains(Cel.Value)
Case Else: Arl.Add Cel.Value
End Select
Next
Arl.Sort
Get_Agences = Arl.ToArray
Set Arl = Nothing
End Function