Transfert des données d'une listbox vers un tableau objet excel

Version imprimable

26/06/2018, 21h01
ramsapat

Transfert des données d'une listbox vers un tableau objet excel

Bonjour, je souhaiterais transférer toutes les données(sauf les 2 premières colonne) donc à partir de la 3e colonne de ma listbox "listbox1" vers un tableau excel "Tableau3" qui se trouve sur la "feuil1".
Ma question est : est ce que c'est possible ??
Et si oui, quelqu'un peut, il m'aider SVP ?
merci a vous.
27/06/2018, 07h39
Theze

Bonjour,

C'est possible mais comme la ListBox a surement sa source sur une feuille Excel, tu pourrais récupérer directement de cette dernière sans passer par la ListBox mais attendons plus d'explications !
27/06/2018, 08h21
ramsapat

bonjour, oui c'est une solution, mais ma listbox ("listbox1") me sert a faire une selection dans la base de donnée selon critère textbox (textbox1) et ce sont uniquement ces données que je veux renvoyer dans mon tableau ("tableau1 ") a l'aide d'un bouton ("bouton1"). j'ai trouver un code qui le fait mais elle ne respect pas la plage de mon tableau("tableau1") pire elle le supprime. et de plus je ne veux pas que les 2 premiere colonne de la listbox("listbox1") soit renvoyer dans le tableau("tableau1").
pour info ma listbox ("listbox1") possède 17 colonnes et mon tableau("tableau1") en possède que 15.
voici le code:

re bonjour, voila j'ai trouver un code ici qui pourrais fonctionner mais elle insert les données en dépassant de ma plage tableau("tableau1") et n'efface pas non plus les données déjà présent dans le tableau.
si quelqu'un peut m'aider svp merci.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
Private Sub CommandButton1_Click()
Dim Ws As Worksheet
Dim ListObj As ListObject
Dim NomTableau As String
Dim DerLign As Long
 
Set Ws = Worksheets("feuil1")
    For Each ListObj In Ws.ListObjects
        NomTableau = ListObj.Name 
    Next
    If NomTableau <> "" Then 
        If NomTableau <> "Tableau1" Then 
            Worksheets("feuil1").ListObjects(NomTableau).Name = "Tableau1" 
        End If
    Else
        ActiveSheet.ListObjects.Add(xlSrcRange, Range("$C$13:$P$14"), , xlYes).Name = "Tableau1"
    End If
If ListBox1.ListCount <> 0 Then
        With Sheets("feuil1").ListObjects("Tableau1")
            i = .ListRows.Count   
            .ListRows.Add 
            i = .ListColumns("Colonne1").Range.Find("", SearchDirection:=xlNext).Row
            i = i - .HeaderRowRange.Row
            a = ListBox1.ListCount - 1
 
            For NumList = 0 To a
               .ListColumns("Colonne1").DataBodyRange.Rows(i).Value = ListBox1.List(NumList, 2)
               .ListColumns("Colonne2").DataBodyRange.Rows(i).Value = ListBox1.List(NumList, 3)
               .ListColumns("Colonne3").DataBodyRange.Rows(i).Value = ListBox1.List(NumList, 4)
               .ListColumns("Colonne4").DataBodyRange.Rows(i).Value = ListBox1.List(NumList, 5)
               .ListColumns("Colonne5").DataBodyRange.Rows(i).Value = ListBox1.List(NumList, 6)
               .ListColumns("Colonne6").DataBodyRange.Rows(i).Value = ListBox1.List(NumList, 7)
               .ListColumns("Colonne7").DataBodyRange.Rows(i).Value = ListBox1.List(NumList, 8)
               .ListColumns("Colonne8").DataBodyRange.Rows(i).Value = ListBox1.List(NumList, 9)
               .ListColumns("Colonne9").DataBodyRange.Rows(i).Value = ListBox1.List(NumList, 10)
               .ListColumns("Colonne10").DataBodyRange.Rows(i).Value = ListBox1.List(NumList, 11)
               .ListColumns("Colonne11").DataBodyRange.Rows(i).Value = ListBox1.List(NumList, 12)
               .ListColumns("Colonne12").DataBodyRange.Rows(i).Value = ListBox1.List(NumList, 13)
               .ListColumns("Colonne13").DataBodyRange.Rows(i).Value = ListBox1.List(NumList, 14)
               .ListColumns("Colonne14").DataBodyRange.Rows(i).Value = ListBox1.List(NumList, 15)
               .ListColumns("Colonne15").DataBodyRange.Rows(i).Value = ListBox1.List(NumList, 16)
 
               i = i + 1
            Next NumList
        End With
 
    Else
        MsgBox "la Liste est vide"
    End If
End Sub

29/06/2018, 19h52
ramsapat

Bonjour le forum,
Voilà, je reviens vers vous avec un fichier qui fait grossièrement ce que je voulais, mais comme je vous ai dit je suis plus que nul en VBA et comme d'hab, c'est du gros bricolage de code et de plus, j'ai un souci de format de donnée une fois importer. Si quelqu'un peut résoudre le problème de format et du même coup remettre un peut d'ordre dans mes codes ça serai vraiment très sympas de votre part. Merci de d'avoir pris le temps de me lire
30/06/2018, 13h07
ramsapat

Apparemment personne ne veux m'aider si je comprends bien ???

1 pièce(s) jointe(s)

Bonjour

Code:

1
2
3
4
5
6
7
8
9
10
11
12
 
Set f2 = Sheets("résultatTableau")
f2.Cells.Clear
Tbl = Me.ListBox1.List
f2.[A2].Resize(UBound(Tbl) + 1, UBound(Tbl, 2) + 1) = Tbl
TblTitre = Sheets("bd").ListObjects(1).HeaderRowRange ' Titres
For c = 1 To UBound(TblTitre, 2)
   f2.Cells(1, c) = TblTitre(1, c)
Next c
f2.ListObjects.Add(xlSrcRange, f2.Range("A1").Resize(UBound(Tbl) + 2, UBound(TblTitre, 2)), , xlYes).Name = "Tableau2"
f2.ListObjects("Tableau2").TableStyle = "TableStyleMedium15"
f2.Cells.EntireColumn.AutoFit

Autre méthode en ajoutant les enregistrements un par un

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
 
Set f2 = Sheets("RésultatTableau")
f2.Cells.Clear
'--- création tableau
TblTitre = Sheets("bd").ListObjects(1).HeaderRowRange ' on prend les titres d'un autre tableau
For c = 1 To UBound(TblTitre, 2)
  f2.Cells(1, c) = TblTitre(1, c)
Next c
f2.ListObjects.Add(xlSrcRange, f2.Range("A1").Resize(, UBound(TblTitre, 2)), , xlYes).Name = "Tableau2"
f2.ListObjects("Tableau2").TableStyle = "TableStyleMedium15"
'--- Transfert 
Tbl = Me.ListBox1.List 
For i = LBound(Tbl) To UBound(Tbl)
   f2.ListObjects(1).ListRows.Add ' Ajout d'une ligne en fin
   For c = 0 To UBound(Tbl, 2)
     f2.ListObjects(1).DataBodyRange.Item(i + 1, c + 1) = Tbl(i, c)
   Next c
Next i
f2.Cells.EntireColumn.AutoFit

Boisgontier

30/06/2018, 21h41
ramsapat

Bonjour, un grand merci a toi boisgontierjacques
maintenant avec ton code je vais pouvoir avancer ! encore merci:)