Microsoft 365 Transfert sélection multiple Listbox

Scorpio

XLDnaute Impliqué
Bonjour à tous,
J'ai trouvé sur le net, ce classeur, dont je ne suis pas le créateur, hélas :(:(, mais, qui me serais bien utile,
Et, j'aimerais lorsque la sélection est crée, transférer cette sélection dans la feuille "RECUP".
Je vous en remercie d'avance et a++++
Scorpio
 

Pièces jointes

  • FiltreListBoxMultiSelection.xlsm
    32.7 KB · Affichages: 14

cp4

XLDnaute Barbatruc
Bonjour Scorpio,

c'était assez simple pourtant;)
VB:
Private Sub CommandButton1_Click()
    Dim i As Integer, j As Byte, dl As Integer
    If ListBox2.ListCount > 0 Then
        With Sheets("recup")
            dl = .Cells(Rows.Count, 1).End(xlUp).Row + 1
            For i = 0 To ListBox2.ListCount - 1
                For j = 0 To ListBox2.ColumnCount - 1
                    .Cells(dl + i, j + 1) = ListBox2.List(i, j)
                Next j
            Next i
        End With
    End If
End Sub

Bon courage pour la suite.
 

danielco

XLDnaute Accro
Bonjour,

Essaie :

VB:
Private Sub CommandButton1_Click()
    Dim Sh As Worksheet, Ligne As Integer, Plage As Range
    With Me.ListBox1
        For i = 0 To .ListCount - 1
            If .Selected(i) = True Then
                With Sheets("BD")
                  Set Plage = .Range(.Cells(i + 2, 1), .Cells(i + 2, 7))
                End With
                With Sheets("RECUP")
                  Ligne = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                  .Cells(Ligne, 1).Resize(, 7).Value = Plage.Value
                End With
            End If
        Next i
    End With
End Sub

Daniel
 

Scorpio

XLDnaute Impliqué
Salut cp4 et danielco,
A oui, pour des pro comme vous, c'est du simple, pour moi, en VBA, je suis pas au top. :p
Dites, serais-t-il possible encore une petite correction.
En fait, lors d'un transfert, il faudrait supprimer le transfert précédent, pour n'accepter que le transfert réscent.
Merci beaucoup A+++
 

danielco

XLDnaute Accro
VB:
Private Sub CommandButton1_Click()
    Dim Ligne As Integer, Plage As Range
    With Sheets("RECUP")
      .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 7).Value = ""
    End With
    With Me.ListBox1
        For i = 0 To .ListCount - 1
            If .Selected(i) = True Then
                With Sheets("BD")
                  Set Plage = .Range(.Cells(i + 2, 1), .Cells(i + 2, 7))
                End With
                With Sheets("RECUP")
                  Ligne = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                  .Cells(Ligne, 1).Resize(, 7).Value = Plage.Value
                End With
            End If
        Next i
    End With
End Sub

Daniel
 

cp4

XLDnaute Barbatruc
Salut cp4 et danielco,
A oui, pour des pro comme vous, c'est du simple, pour moi, en VBA, je suis pas au top. :p
Dites, serais-t-il possible encore une petite correction.
En fait, lors d'un transfert, il faudrait supprimer le transfert précédent, pour n'accepter que le transfert réscent.
Merci beaucoup A+++
VB:
Private Sub CommandButton1_Click()
    Dim i As Integer, j As Byte, dl As Integer
    If ListBox2.ListCount > 0 Then
        With Sheets("recup")
            dl = .Cells(Rows.Count, 1).End(xlUp).Row    'renvoi derniere ligne non vide en colonne A
            If dl > 1 Then .Range(.Cells(2, 1), .Cells(dl, 7)).Clear   'suppression precedentes lignes

            For i = 0 To ListBox2.ListCount - 1
                For j = 0 To ListBox2.ColumnCount - 1
                    .Cells(2 + i, j + 1) = ListBox2.List(i, j)    'boucle de transfert
                Next j
                .Cells(2 + i, 7).Value = .Cells(2 + i, 7).Value * 1    'conversion format nombre
            Next i
        End With
    End If
MsgBox "Transfert terminé!", vbOKOnly + vbInformation, "TRANSFERT"
End Sub
 

Discussions similaires

Réponses
8
Affichages
299
Réponses
18
Affichages
505

Statistiques des forums

Discussions
311 725
Messages
2 081 940
Membres
101 845
dernier inscrit
annesof