Lien hypertexte

Sub Adresse()
Dim cel As Range
On Error Resume Next 'sécurité, si pas de lien hypertexte
For Each cel In Range("A1", [A65536].End(xlUp))
  cel = cel.Hyperlinks(1).Address
Next
End Sub

Sub Images()
Dim coef#, p As Object
coef = 22 'à adapter
For Each p In ActiveSheet.Pictures
  p.Width = p.TopLeftCell.Offset(, -1) / coef
Next
End Sub

Sub CreerShapes()
Dim coef#, h#, s As Shape, cel As Range
coef = 22 'à adapter
h = 8 'hauteur des Shapes, à adapter
Application.ScreenUpdating = False
'---suppression de toutes les Shapes---
For Each s In ActiveSheet.Shapes
  s.Delete
Next
'---création des nouvelles Shapes---
For Each cel In Range("D1", [D65536].End(xlUp))
  If IsNumeric(cel.Text) Then
    Set s = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
      cel.Offset(, 1).Left, cel.Top, cel / coef, h)
    s.Fill.ForeColor.SchemeColor = 12 'bleu '10 'rouge
  End If
Next
End Sub

Sub CreerShapes()
Dim coef#, h#, s As Shape, cel As Range
coef = 22 'à adapter
h = 8 'hauteur des Shapes, à adapter
Application.ScreenUpdating = False
'---suppression de toutes les Shapes---
For Each s In ActiveSheet.Shapes
  s.Delete
Next
'---création des nouvelles Shapes---
For Each cel In Range("D1", [D65536].End(xlUp))
  If IsNumeric(cel.Text) Then
    Set s = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
      cel.Offset(, 1).Left, cel.Top + (cel.Height - h) / 2, cel / coef, h)
    s.Fill.ForeColor.SchemeColor = 12 'bleu '10 'rouge
  End If
Next
End Sub

For Each cel In Range("D1", [D65536].End(xlUp))

For Each cel In Range("D1", [D65536].End(xlUp).Offset(-1, 0))

For Each cel In Range("D1", [D65536].End(xlUp)(0))

'---création des nouvelles Shapes---
On Error Resume Next 'si aucune constante numérique
For Each cel In [D:D].SpecialCells(xlCellTypeConstants, 1)
  Set s = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
    cel.Offset(, 1).Left, cel.Top + (cel.Height - h) / 2, cel / coef, h)
  s.Fill.ForeColor.SchemeColor = 12 'bleu '10 'rouge
Next
End Sub