XL 2019 Problème liens Hypertexte

Zapinet · 22 Décembre 2022

Bonjour,

J'ai un petit problème sur mon code VBA.
Je Recherche un fichier PDF sur mon PC via le Bouton "Fichier joint" une fois valider il viens dans ma listbox en dessous . Puis quand je double clic sur la listbox le liens ce transfère dans la TextBox en dessous. Quand je Clic sur Valider je veux que le lien Hypertexte aille dans la colone B avec pour TextTodisplay = Txtinter. Value (soit la text box N°d'inter).
Tout fonctionne sauf... que mon numéro d'inter va bien en "B" sans hypertext et le lien HyperText que je désire va sur une autre cellule avec le nom de numéro d'inter et en liens Hypertexte.

Le Code :

VB:

Private Sub CBXFichier_Click()
Dim fichier_choisi As String

fichier_choisi = Application.GetOpenFilename("Fichiers Adobe PDF (*.pdf), *.pdf*", , "Sélectionner une intervention")

If (LCase(fichier_choisi) <> "faux" And fichier_choisi <> "0") Then
    liste_fichiers.AddItem (fichier_choisi)
   
    End If
   

End Sub

Private Sub CMDFERMER_Click()

Unload Me

End Sub

Private Sub liste_fichiers_DblClick(ByVal cancel As MSForms.ReturnBoolean)

Txtfichier.Text = liste_fichiers.List(liste_fichiers.ListIndex, 0)

End Sub


Private Sub Cmdvalider_Click()

Sheets("ARCHIVES 2").Select



Dim L As Integer
Dim i As Integer

 If MsgBox("Confirmez-vous l'insertion de cette nouvelle intervention ?", vbYesNo, "Demande de confirmation d'ajout") = vbYes Then
     'L = Sheets("ARCHIVES 2").Range("a65536").End(xlUp).Row + 1

        For i = 6 To 6500
        If Range("B" & i).Value = "" Then
        L = i
        i = 6600
        End If
        Next i
       
 ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Me.Txtfichier.Value, TextToDisplay:=Txtinter.Value

     Range("B" & L).Value = Txtfichier
     Range("B" & L).Value = Txtinter
     Range("C" & L).Value = Txtcstc
     Range("D" & L).Value = Txtadresse
     Range("E" & L).Value = Txtdemande
     Range("F" & L).Value = CBXcate
     Range("G" & L).Value = CBXope
     Range("H" & L).Value = CBXstatique
     Range("I" & L).Value = CBXosg
     Range("J" & L).Value = Txtdate

 End If
'Sheets("STATIQUE").Select

End Sub



Private Sub UserForm_Initialize()
Txtdate.Value = Format(Date, "dd / mm / yyyy")
End Sub

TooFatBoy · 22 Décembre 2022

Phil69970 à dit:
Nous ce que l'on attends c'est 3 ou 4 lignes remplis correctement à la main

100 % d'accord avec cela. Cela aurait été beaucoup mieux !

Je fais tout de même une proposition en pièce jointe, avec modification de la macro Cmdvalider_Click.

VB:

Private Sub Cmdvalider_Click()
'
Dim L As Integer
'Dim i As Integer

    With Sheets("ARCHIVES 2")

        .Select     ' Inutile, sauf si on veut absolument que l'utilisateur voit la feuille avant de répondre à la question posée

        If MsgBox("Confirmez-vous l'insertion de cette nouvelle intervention ?", vbYesNo, "Demande de confirmation d'ajout") = vbYes Then

'            L = Sheets("ARCHIVES 2").Range("a65536").End(xlUp).Row + 1
'            For i = 6 To 6500
'...

TooFatBoy · 22 Décembre 2022

Phil69970 à dit:
Marcel pourquoi ne pas chercher directement la dernière ligne de la colonne B au lieu de passer par un test sur B7 et après chercher la cellule vide de la colonne B à partir de B6 ?

Parce que ça me semble plus logique et cohérent : rien ne nous dit s'il y a ou non quelque chose en-dessous du tableau.

Zapinet · 22 Décembre 2022

TooFatBoy à dit:

100 % d'accord avec cela. Cela aurait été beaucoup mieux !

Je fais tout de même une proposition en pièce jointe, avec modification de la macro Cmdvalider_Click.

VB:

Private Sub Cmdvalider_Click()
'
Dim L As Integer
'Dim i As Integer

    With Sheets("ARCHIVES 2")

        .Select     ' Inutile, sauf si on veut absolument que l'utilisateur voit la feuille avant de répondre à la question posée

        If MsgBox("Confirmez-vous l'insertion de cette nouvelle intervention ?", vbYesNo, "Demande de confirmation d'ajout") = vbYes Then

'            L = Sheets("ARCHIVES 2").Range("a65536").End(xlUp).Row + 1
'            For i = 6 To 6500
'                If Range("B" & i).Value = "" Then
'                    L = i
'                    i = 6600
'                End If
'            Next i
            If .Range("B7").Value = "" Then
                L = 7
            Else
                L = .Range("B6").End(xlDown).Row + 1
            End If
 
'            ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Txtfichier.Value, TextToDisplay:=Txtinter.Value

'            .Range("B" & L).Value = Txtfichier
'            .Range("B" & L).Value = Txtinter
            .Hyperlinks.Add Anchor:=.Range("B" & L), Address:=Txtfichier.Value, TextToDisplay:=Txtinter.Value
            .Range("C" & L).Value = Txtcstc
            .Range("D" & L).Value = Txtadresse
            .Range("E" & L).Value = Txtdemande
            .Range("F" & L).Value = CBXcate
            .Range("G" & L).Value = CBXope
            .Range("H" & L).Value = CBXstatique
            .Range("I" & L).Value = CBXosg
            .Range("J" & L).Value = Txtdate

        End If

    End With

'    Sheets("STATIQUE").Select

End Sub

Je pense que ton problème de lien qui ne se mettait pas au bon endroit venait du Anchor de ton lien : avec Anchor:=Selection le lien va se mettre dans la cellule sélectionnée, qui n'est pas forcément dans la colonne B ni sur la ligne désirée...

Super !!! ca fonctionne merci beaucoup tu m'enlève une sacré épine du pied.
J'essaye de m'amélioré encore mais la route est longue ^^ heureusement que vous êtes la .
Bonne fin de fin d'année à vous.

XL 2019 Problème liens Hypertexte

Zapinet

XLDnaute Nouveau

Pièces jointes

TooFatBoy

TooFatBoy

XLDnaute Barbatruc

Zapinet

XLDnaute Nouveau

Discussions similaires