Microsoft 365 ListBox - colonne Lien Hypertexte

[Scorpio]

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 à ++++

 

[job75]

Bonjour Scorpio,

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+

 

[Scorpio]

Bonjour job75,
OK, merci de t'intéressé a mon souci, mais je n'ai pas de feuille recup, et pas de feuille BD, et ou je place ce code s'il te plaît

 

[Scorpio]

RE job75,
Est-ce que j'ai bien envoyé ce classeur ??

 

[job75]

ou je place ce code s'il te plaît

Bah mon code remplace la macro CmdRecup_Click du fichier que vous avez déposé au post #1.

 

[Scorpio]

A oui, c'est une erreur de ma part, excusez...
Le bon classeur est celui du poste #4

 

[job75]

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.

 

[Scorpio]

OK, super job75, merci beaucoup, ça marche.
J'aimerais juste encore demander une petite correction, c'est d'ajouter lors du transfert, la somme au bas de la colonne "C"
Merci job75

 

[job75]

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.

 

[Scorpio]

Salut job75,
Je viens de voir ton message ce matin,
C'est du boulot de pro, je t'en remercie beaucoup, super.
Vous êtes des champion sur le Forum, merci et à+++++

 

[Scorpio]

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.

 

[job75]

Bonjour Scorpio,

A priori le transfert se fait dans une seule feuille non ?

Alors pourquoi des CheckBoxes ? Il vaut mieux des OptionButtons.

A+

 

[Scorpio]

Bonjour job75,
Mais oui, pas de souci, libre à toi de faire au mieux, je te remercie, à++++

 

[Scorpio]

Re bonjour job75,
Je m'excuse, j'ai oublié de préciser,
que lors du transfert ligne par ligne, je supprime la ligne dans la feuil1, et cette ligne est ajoutée à la suite dans la feuille que je choisirais.
Merci job75, à plus

 

[job75]

Voyez le fichier joint et le code du 2ème bouton de transfert :

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.