Private Sub Worksheet_Activate()
With Feuil1.ListObjects(1).Range
.Sort .Columns(2), xlAscending, Header:=xlYes 'tri
With .Cells(1).CurrentRegion
If .Rows.Count > 1 Then .Columns(2).Offset(1).Resize(.Rows.Count - 1).Name = "Liste" Else ThisWorkbook.Names.Add "Liste", "=#N/A"
End With
End With
With ListObjects(1).Range
With .Cells(2, 1).Resize(.Rows.Count - 1).Validation
.Delete
If Not IsError([Liste]) Then .Add xlValidateList, Formula1:="=Liste"
End With
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim z, i&, j As Variant
Application.ScreenUpdating = False
Application.CutCopyMode = 0
z = ActiveWindow.Zoom 'mémorise
ActiveWindow.Zoom = 100 'c'est nécessaire
On Error Resume Next 'si l'image ne se crée pas
DrawingObjects.Delete 'RAZ
With ListObjects(1).Range
For i = 2 To .Rows.Count
j = Application.Match(.Cells(i, 1), Feuil1.Columns(2), 0)
If IsNumeric(j) Then
With .Cells(i, 2)
.CopyPicture
While TypeName(Selection) = "Range": Paste: DoEvents: Wend 'en attente du collage
Selection.Top = .Top
Selection.Left = .Left
Selection.Formula = "=" & Feuil1.Cells(j, 1).Address(External:=True)
End With
Application.CutCopyMode = 0
ActiveCell.Activate
End If
Next
End With
ActiveWindow.Zoom = z 'état initial
End Sub