Microsoft 365 ListBox - colonne Lien Hypertexte

Scorpio

XLDnaute Impliqué
Bonjour à tous,
J'ai récupéré ce travail dans le Forum, et j'aimerais, car je ne suis pas un champion VBA, faire une correction.
En fait, j'ajoute dans la colonne "E", de la feuil1, des liens hypertextes, et, lorsque je fait le transfert dans la feuille "Transfert",
le lien ne suis pas, il n'est plus un lien, voilà.
Est-ce qu'un membre pourrais juste, s'il vous plaît, me dépanner.
Je vous en remercie et à ++++
 

Pièces jointes

  • USF_ListBoxMultiSelect.xlsm
    37.5 KB · Affichages: 13

job75

XLDnaute Barbatruc
Bonjour Scorpio,
VB:
Private Sub CmdRecup_Click()
Dim ligne&, i&
ligne = 2
With Sheets("recup")
    .[A2:D1000].ClearContents
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) Then Sheets("BD").Rows(i + 2).Copy .Rows(ligne): ligne = ligne + 1
    Next
    .Visible = xlSheetVisible 'si la feuille est masquée
    Application.Goto .[A1]
End With
Call TriRecup
Unload UserForm1
End Sub
A+
 

job75

XLDnaute Barbatruc
VB:
Private Sub CommandButton1_Click() 'Extraire sur feuille "Transfert"
Dim tablo(), i&, ligne&, x$, j As Variant
With [Tableau1]
    ReDim tablo(1 To .Rows.Count, 1 To 1)
    For i = 1 To .Rows.Count
        tablo(i, 1) = .Cells(i, 1) & .Cells(i, 2) & .Cells(i, 3) & .Cells(i, 4) & .Cells(i, 5)
    Next
End With
ligne = 2
With Sheets("Transfert")
    .[A2:E1000].Clear
    For i = 0 To ListBox1.ListCount - 1
        With ListBox1: x = .List(i, 0) & .List(i, 1) & .List(i, 2) & .List(i, 3) & .List(i, 4): End With
        j = Application.Match(x, tablo, 0)
        If IsNumeric(j) Then
            [Tableau1].Rows(j).Copy .Rows(ligne)
            ligne = ligne + 1
        End If
    Next
    .Visible = xlSheetVisible 'si la feuille est masquée
    Application.Goto .[A1]
End With
Unload UserForm1
End Sub
Mettez des liens hypertextes où vous voulez en Feuil1.
 

job75

XLDnaute Barbatruc
VB:
Private Sub CommandButton1_Click() 'Extraire sur feuille "Transfert"
Dim d As Object, i&, x$, ligne&
Set d = CreateObject("Scripting.Dictionary")
With [Tableau1]
    For i = 1 To .Rows.Count
        x = .Cells(i, 1) & .Cells(i, 2) & .Cells(i, 3) & .Cells(i, 4) & .Cells(i, 5)
        If Not d.exists(x) Then d(x) = i 'mémorise la ligne
    Next
End With
ligne = 2
With Sheets("Transfert")
    .Range("A2:E" & .Rows.Count).Clear
    For i = 0 To ListBox1.ListCount - 1
        With ListBox1: x = .List(i, 0) & .List(i, 1) & .List(i, 2) & .List(i, 3) & .List(i, 4): End With
        If d.exists(x) Then
            [Tableau1].Rows(d(x)).Copy .Rows(ligne)
            ligne = ligne + 1
        End If
    Next
    .Cells(ligne, 2) = "Total"
    .Cells(ligne, 3) = "=SUM(C1:C" & ligne - 1 & ")"
    .Cells(ligne, 3).NumberFormat = "#,##0.00"
    .Cells(ligne, 2).Resize(, 2).Font.Bold = True 'gras
    .Visible = xlSheetVisible 'si la feuille est masquée
    Application.Goto .[A1]
End With
Unload UserForm1
End Sub
Au lieu de Application.Match j'utilise maintenant le Dictionary, c'est plus rapide si le tableau est grand.
 
Dernière édition:

Scorpio

XLDnaute Impliqué
Re bonjour job75,
Est-ce encore possible, s'il te paît, d'apporter des corrections dans mon projet,
si oui,
j'ai ajouté un Frame1 avec 9 CheckBox de feuil2 à feuil10, et 1 bouton de transfert ligne par ligne, et choix de la feuille.
Seulement si c'est possible job75, et merci beaucoup.
 

Pièces jointes

  • ListBoxMultiSelect.xlsm
    51.9 KB · Affichages: 3

job75

XLDnaute Barbatruc
Voyez le fichier joint et le code du 2ème bouton de transfert :
VB:
Private Sub CommandButton3_Click() 'Transfert ligne par ligne sur feuille choisie
Dim tablo(), i&, ligne&, x$, j As Variant
With [Tableau1]
    ReDim tablo(1 To .Rows.Count, 1 To 1)
    For i = 1 To .Rows.Count
        tablo(i, 1) = .Cells(i, 1) & .Cells(i, 2) & .Cells(i, 3) & .Cells(i, 4) & .Cells(i, 5)
    Next
End With
For i = 1 To 9
    If Me("OptionButton" & i) Then Exit For
Next
If i = 10 Then MsgBox "Choisissez une feuille pour le transfert...": Exit Sub
With Sheets(Me("optionButton" & i).Caption)
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    ligne = .Range("A" & .Rows.Count).End(xlUp).Row + 1 '1ère ligne vide
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) Then
            With ListBox1: x = .List(i, 0) & .List(i, 1) & .List(i, 2) & .List(i, 3) & .List(i, 4): End With
            j = Application.Match(x, tablo, 0)
            If IsNumeric(j) Then
                [Tableau1].Rows(j).Copy .Rows(ligne) 'copier-coller
                [Tableau1].Rows(j).Delete xlUp 'supprime la ligne
                ligne = ligne + 1
            End If
        End If
    Next
    .Cells(ligne, 2) = "Total"
    .Cells(ligne, 3) = "=SUM(C1:C" & ligne - 1 & ")"
    .Cells(ligne, 3).NumberFormat = "#,##0.00"
    .Cells(ligne, 2).Resize(, 2).Font.Bold = True 'gras
    .Visible = xlSheetVisible 'si la feuille est masquée
    Application.GoTo .[A1]
End With
Unload UserForm1
End Sub
La propriéte MultiSelect de ListBox1 est sur 1 - fmMultiSelectMulti.

Comme on supprimes des lignes du tableau source on ne peut plus utiliser le Dictionary.

Je n'ai pas modifié la macro du 1er bouton de transfert.
 

Pièces jointes

  • ListBoxMultiSelect(1).xlsm
    55.8 KB · Affichages: 5

Discussions similaires

Réponses
7
Affichages
692

Statistiques des forums

Discussions
314 450
Messages
2 109 727
Membres
110 552
dernier inscrit
jasson