Copie ou déplacement de liens hypertexte

Private Sub Worksheet_Change(ByVal Target As Range)
Dim a$, sa$, d$
If Target.Count = 1 Then
  If Target.Hyperlinks.Count = 1 Then
    a = Target.Hyperlinks(1).Address
    sa = Target.Hyperlinks(1).SubAddress
    d = Target
    Application.EnableEvents = False
    Application.Undo
    Target = d
    If a = "" Then Me.Hyperlinks.Add Target, a, sa _
      Else Me.Hyperlinks.Add Target, a
    Application.EnableEvents = True
  End If
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim a$, sa$
If Target.Count = 1 Then
  If Target.Hyperlinks.Count = 1 Then
    a = Target.Hyperlinks(1).Address
    sa = Target.Hyperlinks(1).SubAddress
    Application.EnableEvents = False
    Application.Undo
    If a = "" Then Me.Hyperlinks.Add Target, a, sa _
      Else Me.Hyperlinks.Add Target, a
    Application.EnableEvents = True
  End If
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim a$, sa$
If Target(1).Hyperlinks.Count = 1 Then
  a = Target(1).Hyperlinks(1).Address
  sa = Target(1).Hyperlinks(1).SubAddress
  Application.EnableEvents = False
  Application.Undo
  For Each Target In Target 'si plusieurs cellules
    If a = "" Then Me.Hyperlinks.Add Target, a, sa _
      Else Me.Hyperlinks.Add Target, a
  Next
  Application.EnableEvents = True
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim a$(), sa$(), t, n&
If Target(1).Hyperlinks.Count Then
  If Target.Count > 10000 Then Exit Sub 'adapter le nombre maximum de cellules
  ReDim a(1 To Target.Count)
  ReDim sa(1 To Target.Count)
  For Each t In Target
    n = n + 1
    If t.Hyperlinks.Count Then
      a(n) = t.Hyperlinks(1).Address
      sa(n) = t.Hyperlinks(1).SubAddress
    End If
  Next
  n = 0
  Application.EnableEvents = False
  Application.Undo
  For Each t In Target
    n = n + 1
    If a(n) <> "" Or sa(n) <> "" Then
      If a(n) = "" Then Me.Hyperlinks.Add t, a(n), sa(n) _
        Else Me.Hyperlinks.Add t, a(n)
      End If
  Next
  Application.EnableEvents = True
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim a$(), sa$(), t, n&, h As Hyperlink
If Target(1).Hyperlinks.Count Then
  If Target.Count > 10000 Then Exit Sub 'adapter le nombre maximum de cellules
  ReDim a(1 To Target.Count)
  ReDim sa(1 To Target.Count)
  For Each t In Target
    n = n + 1
    If t.Hyperlinks.Count Then
      a(n) = t.Hyperlinks(1).Address
      sa(n) = t.Hyperlinks(1).SubAddress
    End If
  Next
  n = 0
  Application.EnableEvents = False
  Application.Undo
  For Each t In Target
    n = n + 1
    If a(n) <> "" Or sa(n) <> "" Then _
      If a(n) = "" Then Me.Hyperlinks.Add t, a(n), sa(n) _
        Else Me.Hyperlinks.Add t, a(n)
    For Each h In Me.Hyperlinks
      If Intersect(h.Parent, Target) Is Nothing And h.Address = a(n) _
        And h.SubAddress = sa(n) Then h.Delete
    Next
  Next
  Application.EnableEvents = True
End If
End Sub