Bonjour,
Pas très facile la question, néanmoins, cela devrait fonctionner
J’ai changer le type de LISTBOX, avec ton exemple, pas pratique pour la sélection.
Module:
Option Explicit
Sub test()
Dim maliste As New Collection
Dim maliste2 As New Collection
Dim i, j%, Dl%, Dl2%
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Feuil3.Cells.CurrentRegion = "" 'efface les données feuil3
For i = 0 To Feuil11.ListBox1.ListCount - 1 'boucle sur feuil11 sur les item cochés
If Feuil11.ListBox1.Selected(i) = True Then
maliste.Add (Feuil11.ListBox1.List(i)) 'place en mémoire les items
maliste2.Add (i) 'place en mémoire les emplacements des items
End If
Next
j = 2
For Each i In maliste 'boucle pour afficher les items de la liste et les place en feuil3 col8
Feuil3.Cells(j, 8) = i
j = j + 1
Next
j = 2
For Each i In maliste2 'boucle pour afficher les N° items de la liste et les place en feuil3 col1
Feuil3.Cells(j, 1) = i + 2
j = j + 1
Next 'Entête colonne
Feuil3.Cells(1, 1) = "Noligne"
Feuil3.Cells(1, 8) = "Recette"
Feuil3.Cells(1, 7) = "Ligne"
Feuil3.Cells(1, 6) = "VP prio"
Feuil3.Cells(1, 5) = "PXRTRI"
Feuil3.Cells(1, 4) = "PXRCMP"
Feuil3.Cells(1, 3) = "PXRVL"
Feuil3.Cells(1, 2) = "PXRART"
Dl = Feuil3.Range("A" & Rows.Count).End(xlUp).Row 'n° de la dernière ligne non vide de la colonne A feuil3
Dl2 = Feuil1.Range("A" & Rows.Count).End(xlUp).Row 'n° de la dernière ligne non vide de la colonne A feuil1
For i = 2 To Dl 'boucle sur les N°de ligne de la feuil3 et récupère les données de la feuil2
j = Feuil3.Cells(i, 1).Value 'valeur du N° de la ligne de l'item en feuil3
Feuil3.Cells(i, 2).Value = Feuil2.Cells(j, 1)
Feuil3.Cells(i, 3).Value = Feuil2.Cells(j, 2)
Feuil3.Cells(i, 7).Value = Feuil2.Cells(j, 4)
Next i
i = 2
For j = 2 To Dl2 'boucle sur la concaténation de la feuil3 et récupère les données de la feuil2
If Feuil3.Cells(i, 2).Value & Feuil3.Cells(i, 3).Value & Feuil3.Cells(i, 7).Value & Feuil3.Cells(i, 8).Value = _
Feuil1.Cells(j, 1).Value & Feuil1.Cells(j, 2).Value & Feuil1.Cells(j, 6).Value & Feuil1.Cells(j, 7).Value Then
Feuil3.Cells(i, 4).Value = Feuil1.Cells(j, 3)
Feuil3.Cells(i, 5).Value = Feuil1.Cells(j, 4)
Feuil3.Cells(i, 6).Value = Feuil1.Cells(j, 5)
i = i + 1
End If
Next j
Feuil3.Activate
Columns("A:A").Select 'supprime la colA (N° de ligne item)
Selection.Delete Shift:=xlToLeft
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Range("A1").Select
End Sub
le Classeur:
Essai (4)test.xlsm (204,5 Ko)