Sub test()
'
' autrefichier Macro
'
Dim NomFichierOuvert As String
NomFichierOuvert = ThisWorkbook.Name
Dim NomOngletFichierOuvert As string
NomOngletFichierOuvert = "Feuil1"
Dim FichierPMI As string
FichierPMI = "test.xls"
Dim NomOngletFichierPMI As string
NomOngletFichierPMI = "Feuil1"
Dim CheminDossier As string
CheminDossier = Application.ActiveWorkbook.Path
Dim CheminFichierPMI As string
CheminFichierPMI = CheminDossier & "\" & FichierPMI
Workbooks.Open CheminFichierPMI
Dim a As Workbook 'déclare la variable a (claseurA)
Dim b As Workbook 'déclare la variable b (claseurB)
Dim oa As Object 'déclare la variable oa (Onglet A)
Dim ob As Object 'déclare la variable ob (Onglet B)
Dim dla As Integer 'déclare la variable dla (Dernière Ligne de l'onglet A)
Dim pla As Range 'déclare la variable pla (PLage A)
Dim dlb As Integer 'déclare la variable dlb (Dernière Ligne de l'onglet B)
Dim plb As Range 'déclare la variable plb (PLage B)
Dim cel As Range 'déclare la variable cel (CELlule)
Dim r As Range 'déclare la variable r (Recherche)
Dim pa As String 'déclare la variable pa (Première Adresse)
Set a = Workbooks(NomFichierOuvert) 'définit le classeur a
Set b = Workbooks(FichierPMI) 'définit le classeur b
Set oa = a.Sheets(NomOngletFichierOuvert) 'définit l'onglet de travail du claseur a
Set ob = b.Sheets(NomOngletFichierPMI) 'définit l'onglet de travail du claseur b
dla = oa.Cells(Application.Rows.Count, 2).End(xlUp).Row 'définit la dernière ligne éditée dla de la colonne B de longlet oa
Set pla = oa.Range("B4:B" & dla) 'définit la plage pla
dlb = ob.Cells(Application.Rows.Count, 2).End(xlUp).Row 'définit la dernière ligne éditée dlb de la colonne B de longlet ob
Set plb = ob.Range("B2:B" & dlb) 'définit la plage plb
For Each cel In plb 'boucle sur toutes les cellules de la plage plb
'condition 1 : si le nombre d'occurrences de la cellule cel dans la plage pla est égal à 1
If Application.WorksheetFunction.CountIf(pla, cel) = 1 Then
'définit la recherche r (recherche la valeur de la cellule cel dans la plage pla)
Set r = pla.Find(cel.Value, , xlValues, xlWhole)
oa.Range(oa.Cells(r.Row, 6), oa.Cells(r.Row, 26)).Copy cel.Offset(0, 4) 'copie les cellules des colonnes F à Z
End If 'fin de la condition 1
'condition : 2 si le nombre d'occurrences de la cellule cel dans la plage pla est supérieur à 1
If Application.WorksheetFunction.CountIf(pla, cel) > 1 Then
'définit la recherche r (recherche la valeur de la cellule cel dans la plage pla)
Set r = pla.Find(cel.Value, , xlValues, xlWhole)
pa = r.Address 'définit l'adresse de la première occurrence trouvée
Do 'exécute
'condition 3 : si la valeur en colonne C de cel correspond à la valeur en colonne C de r
If cel.Offset(0, 1).Value = r.Offset(0, 1).Value Then
oa.Range(oa.Cells(r.Row, 6), oa.Cells(r.Row, 26)).Copy cel.Offset(0, 4) 'copie les cellules des colonnes F à H
End If 'fin de la condition 3
Set r = pla.FindNext(r) 'redéfinit la recherche r (occurrence suivante0
Loop While Not r Is Nothing And r.Address <> pa 'boucle tant qu'il existe des occurrences ailleurs qu'en pa
End If 'fin de la condition 2
Next cel 'prochaine cellule de la boucle
Dim SelectionAvantCopie As String
Windows(FichierPMI).Activate
SelectionAvantCopie = "A2:Z" & dlb
Range(SelectionAvantCopie).Select 'Sélectionne de la Cellule A2 à Z de la dernière ligne dont la collonne B est remplie
Selection.Copy
Windows(NomFichierOuvert).Activate
Range("A4").Select 'Séleection de la Cellule A4 du fichier planning
ActiveSheet.Paste 'Copie de la sélection venant du fichier PMI
Dim dlc As Integer
dlc = dlb + 2
SelectionAvantCopie = "A4:X" & dlc
Range(SelectionAvantCopie).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With 'mise en place quadrillage
With Selection.Font
.Name = "Calibri"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With 'Mise en calibri 10
Dim NomFichier As String
Dim NomCompletFichier As String
Dim CheminCompletFichier As String
NomFichier = "Test"
Dim stHeureExport As String
stHeureExport = "_" & Year(Date) & Format(Month(Date), "00") & Format(Day(Date), "00") & "-" & Format(Hour(Time), "00") & "h" & Format(Minute(Time), "00")
NomCompletFichier = CheminDossier & "\" & NomFichier & stHeureExport & ".xlsm"
CheminCompletFichier = CheminDossier & "\" & NomCompletFichier
'Copie de la feuille courante dans un nouveau classeur et enregistrement
ActiveSheet.Copy
ActiveWorkbook.SaveAs NomCompletFichier, FileFormat:=52
Windows(NomFichierOuvert).Activate
ActiveWorkbook.Close SaveChanges:=False
Windows(FichierPMI).Activate
ActiveWorkbook.Close SaveChanges:=False
Windows(NomCompletFichier).Activate
MsgBox "Voici le fichier généré sous le nom : " & vbCrLf & NomCompletFichier
End Sub
