Option Explicit
Sub testbisNettoyerPatrickToulon()
' ********************************************************************
Dim FGroupSemaine As Worksheet
Set FGroupSemaine = Worksheets("Groupe semaine")
Dim Rg1 As Range
Set Rg1 = Union(FGroupSemaine.Range(FGroupSemaine.Cells(1, 14), FGroupSemaine.Cells(FGroupSemaine.Cells(65536, 14).End(xlUp).Row, 14)), FGroupSemaine.Range(FGroupSemaine.Cells(1, 15), FGroupSemaine.Cells(FGroupSemaine.Cells(65536, 15).End(xlUp).Row, 15)))
Dim Cells1 As Range
Dim sh(1 To 2) As Shape
Set sh(1) = FGroupSemaine.Shapes("AutoShape 13")
Set sh(2) = FGroupSemaine.Shapes("Oval 93")
' ********************************************************************
Dim Factive As Worksheet
Set Factive = Worksheets(ActiveSheet.Name)
Dim Rg2 As Range
Set Rg2 = Union(Factive.Range(Factive.Cells(1, 3), Factive.Cells(Factive.Cells(65536, 3).End(xlUp).Row, 3)), Factive.Range(Factive.Cells(1, 5), Factive.Cells(Factive.Cells(65536, 5).End(xlUp).Row, 5)), Range(Factive.Cells(1, 7), Factive.Cells(Factive.Cells(65536, 7).End(xlUp).Row, 7)))
' *******************************************************************
Dim s As Shape
For Each s In Factive.Shapes
If s.Name = sh(1).Name Or s.Name = sh(2).Name Then
s.Delete
End If
Next s
Dim shap As Shape
Dim Cells2 As Range
For Each Cells2 In Rg2
If Cells2.Value <> Empty Then
For Each Cells1 In Rg1
If Cells1.Value = Cells2.Value Then
If Cells1.Column = 14 Then
With sh(1): .Copy: Factive.Paste: Set shap = ActiveSheet.Shapes(Selection.Name): End With
With shap
.Name = 15 & "-" & Cells2.Row
.Top = Cells2.Top
.Left = Cells2.Left
End With
ElseIf Cells1.Column = 15 Then
With sh(2): .Copy: Factive.Paste: Set shap = ActiveSheet.Shapes(Selection.Name): End With
With shap
.Name = 15 & "-" & Cells2.Row
.Top = Cells2.Top
.Left = Cells2.Left + Cells2.Width - .Width
End With
End If
End If
Next Cells1
End If
Next Cells2
End Sub