1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54
| Sub Intervertir()
Dim CheminP As String 'Chemin des fichiers des postes
Dim CheminS As String 'Chemin des fichiers des salons
Dim CheminM As String 'Chemin du fichier modèle
Dim FichierM As String 'Nom du fichier modèle
Dim FichierP As String 'Nom du fichier de poste en cours
Dim WbFichierP As Workbook 'Classeur de poste en cours
Dim WbFichierM As Workbook 'Classeur du fichier modèle
Dim FeuilleS As Worksheet 'Feuille salon dans le classeur poste en cours
Dim NomLongClass As String 'Nom du classeur salon
Application.ScreenUpdating = False
CheminP = "C:\Users\Pierre Dumas\Desktop\test\Postes\"
CheminS = "C:\Users\Pierre Dumas\Desktop\test\Salons\"
CheminM = "C:\Users\Pierre Dumas\Desktop\test\Modele\"
FichierM = "Salon.xlsx"
'Ouvrir le classeur modèle de salon
Set WbFichierM = Workbooks.Open(CheminM & FichierM)
FichierP = Dir(CheminP & "*.xlsx")
Set WbFichierP = Workbooks.Open(CheminP & FichierP)
For Each FeuilleS In WbFichierP.Worksheets
NomLongClass = "Extr" & FeuilleS.Name & ".xlsx"
If EstDansCollection(Workbooks, NomLongClass) = False Then 'Verifier si le classeur de salon est ouvert. Si ce n'est pas le cas
WbFichierM.SaveCopyAs CheminS & NomLongClass 'Duppliquer le classeur modèle avec le nom de ce salon
Workbooks.Open Filename:=CheminS & NomLongClass 'Ouvrir ce nouveau classeur
End If
MsgBox (Workbooks(NomLongClass).Sheets("REALISE").CodeName)
'Suite macro
Exit For
Next FeuilleS
WbFichierP.Close
Set WbFichierP = Nothing
Application.ScreenUpdating = True
End Sub
Private Function EstDansCollection(Coln As Object, Item As String) As Boolean
Dim Obj As Object
On Error Resume Next
Set Obj = Coln(Item)
EstDansCollection = Not Obj Is Nothing
End Function |
Partager