Sub testbisNettoyer()
' ********************************************************************
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 item1 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 item2 As Range
For Each item2 In Rg2
If item2.Value <> Empty Then
For Each item1 In Rg1
If item1.Value = item2.Value Then
If item1.Column = 14 Then
Set s = sh(1).Duplicate
s.Name = "x": s.Copy: Factive.Paste
With Factive.Shapes.Range(Array(s.Name))
.Top = item2.Top
.Left = item2.Left
.Name = sh(1).Name
End With
ElseIf item1.Column = 15 Then
Set s = sh(2).Duplicate
s.Name = "x": s.Copy: Factive.Paste
With Factive.Shapes.Range(Array(s.Name))
.Top = item2.Top
.Left = item2.Left + item2.Width - .Width
.Name = sh(2).Name
End With
End If
End If
Next item1
End If
Next item2
End Sub