Sub Transferer()
Dim T1 As Range, T2 As Range, dest As Range
Set T1 = Sheets("Support").[A4].CurrentRegion 'à adapter
Set T2 = Sheets("Support").[F4].CurrentRegion 'à adapter
On Error Resume Next
Set dest = Application.InputBox("Sélectionnez la cellule de destination :", "Cellule", Type:=8)
On Error GoTo 0
If dest Is Nothing Then Exit Sub
IIf(ActiveSheet.DrawingObjects(Application.Caller).Text = "ACHAT", T1, T2).Copy dest(1)
With dest(1, 2)
.Formula = "=HYPERLINK(""#'" & .Parent.Name & "'!A1"",""HAUT"")"
.Font.ColorIndex = 3 'rouge
.Font.Bold = True 'gras
End With
End Sub