Sub TrierSurColonneA()
Dim derlig&, o As Object, r As Range, i&, rc&, x, j%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Feuil1 'CodeName de la feuille
.Columns("L").Resize(, .Columns.Count - 11).Clear 'nettoyage
derlig = .Range("A" & .Rows.Count).End(xlUp).Row
If derlig < 7 Then Exit Sub
'---repère en colonne L pour les images---
For Each o In .DrawingObjects
If o.TopLeftCell.Column = 3 Then
o.Placement = 2 'fige les dimensions
.Cells(o.TopLeftCell.Row, 12) = o.Name
End If
Next o
'---traitement du tableau---
Set r = .Range(.Rows(7), .Range("A" & derlig).MergeArea)
r.UnMerge 'défusionne les cellules
r.Borders.LineStyle = xlNone 'suppression des bordures
If Application.CountBlank(r.Columns(1)) Then _
r.Columns(1).SpecialCells(xlCellTypeBlanks) = "=R[-1]C"
r.Columns(1) = r.Columns(1).Value 'supprime les formules
r.Sort r(1), xlAscending, Header:=xlNo 'tri sur la colonne A
rc = r.Rows.Count
For i = 1 To rc
x = r(i, 1)
For j = i + 1 To rc
If r(j, 1) <> x Then Exit For
Next j
r(i, 1).Resize(j - i).Merge 'refusionne
r(i, 2).Resize(j - i).Merge
r(i, 4).Resize(j - i).Merge
r(i, 5).Resize(j - i).Merge
r.Rows(i).Resize(, 11).Borders(xlEdgeTop).Weight = xlMedium 'bordure superieure
i = j - 1
Next i
For i = 7 To 11: r.Resize(, 11).Borders(i).Weight = xlMedium: Next i
Intersect(r, .[A:B,D:E]).Borders.Weight = xlMedium
r.Columns(3).HorizontalAlignment = xlLeft
r.Columns(3).Rows.AutoFit 'ajustement hauteurs
'---positions et dimensions des images---
For Each o In .DrawingObjects
If o.TopLeftCell.Column = 3 Then
.Shapes(o.Name).LockAspectRatio = msoTrue
i = Application.Match(o.Name, r.Columns(12), 0)
o.Top = r(i, 3).Top + 2
o.Left = r(i, 3).Left + 2
o.Height = r(i, 1).MergeArea.Height - 4
Intersect(r(i, 1).MergeArea.EntireRow, r.Columns(3)).Merge 'fusion des cellules sous l'image
End If
Next o
.[L:L].ClearContents 'RAZ
End With
End Sub