Copier un lien hypertexte avec une macro

Bonjour,

J'ai fais une base de donnée avec une page pour rechercher dans la base. Cependant, je veux mettre des liens hypertexte dans la base. Or quand je fais ça, les liens ne sont pas copier sur la page de recherche.

Comment faire?

Je vous met mon fichier ci-dessous.

Merci de votre aide!

Personne n'a une idée, ça devient urgent!

Merci d'avance

Bonjour

l'urgent est fait, l'impossible est en cours, pour les miracles prévoir un délai

Remplaces ta macro par celle-ci (pas mieux en stock)

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Lg As Long

  If Not Application.Intersect(Target, Range("B5:F5")) Is Nothing Then
    Range("B9:E" & Range("B" & Rows.Count).End(xlUp).Row).ClearContents
    With Sheets("Base")
      On Error Resume Next
      .ShowAllData
      On Error GoTo 0
      Lg = .Range("A" & Rows.Count).End(xlUp).Row
      [TABLO].AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=[Criteres], Unique:=False
      .Range("G4:J" & Lg).SpecialCells(xlCellTypeVisible).Copy [Extraction]
      .ShowAllData
    End With
  End If
End Sub

Merci Banzai64! C'est ce que je voulais.

Cependant, il reste un problème.

En exécutant ton code, cela modifie la présentation de la ligne B9 (Marque,Référence,...).

Par exemple, si c'est en gras, ça redevient pas! Si c'est en bleu, ça redevient en noir.

Je pense que ça doit pas être grand chose à changer dans ton code, mais si tu pouvais m'aider ça serait sympa!!

Merci d'avance!!

Bonjour

Remplaces la macro

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Lg As Long

  If Not Application.Intersect(Target, Range("B5:F5")) Is Nothing Then
    If Range("B10") <> "" Then
      Range("B10:E" & Range("B" & Rows.Count).End(xlUp).Row).ClearContents
    End If

    With Sheets("Base")
      On Error Resume Next
      .ShowAllData
      On Error GoTo 0
      Lg = .Range("A" & Rows.Count).End(xlUp).Row
      [TABLO].AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=[Criteres], Unique:=False
      If Application.Subtotal(103, .Range("A5:A" & Lg)) > 0 Then
        .Range("G5:J" & Lg).SpecialCells(xlCellTypeVisible).Copy Range("B10")
      End If
      .ShowAllData
    End With
  End If
End Sub

Merci pour ton aide, c'est tout-à-fait ça!!