Microsoft 365 Tablo ( Array) avec colonnes discontinues

Regueiro

XLDnaute Impliqué
Bonjour le Forum
Problème d'alimentation de mon Tablo
Lorsque les colonnes sont continues exemple 1 2 3 pas de problème
Pourriez-vous me trouver une solution
VB:
Private Sub TextBox1_Change()
Dim i, clé, n
Dim rngData As Range
Dim x
Set FL = Worksheets("CHANTIER")
Set LSTOBJ = FL.ListObjects("CHANTIEROUVERTURE")

With LSTOBJ.DataBodyRange
    Set rngData = Application.Union(.Columns(1), .Columns(4), .Columns(5))  '4 et 5
End With
'Tbl = Tableau(Rng)
'fonction de Boisgontier
tablo = Tableau(rngData)
'tablo = rngData.Value
MsgBox tablo(1, 3)

Function Tableau(Rng)
Dim nbLig, nbcol
Dim i, j
  nbLig = Rng.Rows.Count: nbcol = Rng.Areas.Count
  Dim Tbl(): ReDim Tbl(1 To nbLig, 1 To nbcol)
  For i = 1 To nbcol
    For j = 1 To nbLig: Tbl(j, i) = Rng.Areas(i)(j): Next j
  Next i
  Tableau = Tbl
End Function
 

Staple1600

XLDnaute Barbatruc
Bonsoir le fil, Regueiro

Test OK avec un ListObject
(ici dans l'exemple A1:F20)
VB:
Sub test_OK()
Dim L_Obj As ListObject, vArr
Set L_Obj = ActiveSheet.ListObjects(1)
vCols = Array(2, 4, 6) 'on choisit les colonnes 2,4 et 6
pL = L_Obj.Range(2, 1).Row '1ière ligne du ListObject
dL = L_Obj.DataBodyRange.Rows.Count ' dernière ligne du ListObject
xL = Evaluate("row(" & pL & ":" & dL & ")")
vArr = Application.Index(L_Obj.DataBodyRange, xL, vCols)
MsgBox vArr(LBound(vArr), 1)
MsgBox vArr(UBound(vArr), 1)
MsgBox vArr(LBound(vArr), 3)
MsgBox vArr(UBound(vArr), 3)
MsgBox vArr(5, 2)
MsgBox vArr(6, 2)
End Sub
 

job75

XLDnaute Barbatruc
Bonsoir Regueiro, JM,

Au post #1 Regueiro désire créer une fonction donc voyez le fichier joint et ces codes :
VB:
Sub Test()
Dim rngData As Range, tablo
With Sheets("CHANTIER").ListObjects("CHANTIEROUVERTURE").DataBodyRange
    Set rngData = Union(.Columns(1), .Columns(4), .Columns(5))  '1, 4 et 5
End With
tablo = Tableau(rngData)
MsgBox "1ère ligne => " & tablo(1, 1) & " " & tablo(1, 2) & " " & tablo(1, 3) 'pour tester
End Sub

Function Tableau(Rng As Range)
Dim a As Range, n%, nlig&, ncol%, Tbl(), i&, j%
For Each a In Rng.Areas
    If n = 0 Then nlig = a.Rows.Count
    If a.Rows.Count <> nlig Then MsgBox "Plage non valide !", 48: End
    ncol = a.Columns.Count
    n = n + ncol
    ReDim Preserve Tbl(1 To nlig, 1 To n)
    For i = 1 To nlig
        For j = 1 To ncol
        Tbl(i, n - ncol + j) = a(i, j)
Next j, i, a
Tableau = Tbl
End Function
A+
 

Pièces jointes

  • Classeur(1).xlsm
    20.2 KB · Affichages: 22

Regueiro

XLDnaute Impliqué
Bonsoir le Forum, staple1600, job75.
Merci pour votre retour.
Voici le code plus court.
VB:
Option Explicit
Dim tablo() As Variant
Dim FL As Worksheet
Dim LSTOBJ As ListObject
Private Sub TextBox1_Change()
Dim i, clé, n
Dim LSTR As Range
Dim NBLIG As Integer      'Nombres de lignes

Set FL = Worksheets("CHANTIER")
Set LSTOBJ = FL.ListObjects("CHANTIEROUVERTURE")
Set LSTR = LSTOBJ.DataBodyRange
NBLIG = LSTR.Rows.Count
tablo = Application.Index(LSTR, LSTOBJ.Parent.Evaluate("ROW(1:" & NBLIG & ")"), Array(1, 4, 5))
'MsgBox tablo(1, 3)
 

Staple1600

XLDnaute Barbatruc
Re

OK alors ma version raccourcie de ma version du message#2
VB:
Sub Test_OK_Shorter()
Dim vArr
With ActiveSheet.ListObjects(1)
    xL = Evaluate("ROW(1:" & .DataBodyRange.Rows.Count & ")")
    vArr = Application.Index(.DataBodyRange, xL, Array(2, 4, 6))
End With
MsgBox vArr(5, 2)
MsgBox vArr(6, 2)
End Sub
 

job75

XLDnaute Barbatruc
Bonjour Regueiro, JM,

Voici tout de même la fonction avec 2 arguments, le 2ème déterminant le choix des colonnes :
VB:
Function Tableau(Rng As Range, ArrayCol)
Tableau = Application.Index(Rng, Evaluate("ROW(1:" & Rng.Rows.Count & ")"), ArrayCol)
End Function

Sub Test()
Dim tablo
tablo = Tableau(Sheets("CHANTIER").ListObjects("CHANTIEROUVERTURE").DataBodyRange, Array(1, 4, 5))
MsgBox "1ère ligne => " & tablo(1, 1) & " " & tablo(1, 2) & " " & tablo(1, 3) 'pour tester
End Sub
A+
 

Pièces jointes

  • Classeur(2).xlsm
    19.5 KB · Affichages: 12

patricktoulon

XLDnaute Barbatruc
re
une version spécial listobject l'array des colonnes est obtenu par leur nom
VB:
Function Tableau(LstObj As ListObject, ArrayCol)
    Dim Rng As Range, I&
    Set Rng = LstObj.DataBodyRange
    For I = 0 To UBound(ArrayCol): ArrayCol(I) = LstObj.ListColumns(ArrayCol(I)).Index: Next
    Tableau = Application.Index(Rng, Evaluate("ROW(1:" & Rng.Rows.Count & ")"), ArrayCol)
End Function

Sub test()
    Dim tablo, colonnes
    colonnes = Array("Colonne1", "Colonne4", "Colonne5")
    tablo = Tableau(Sheets("CHANTIER").ListObjects("CHANTIEROUVERTURE"), colonnes)
    
    MsgBox "1ère ligne => " & tablo(1, 1) & " " & tablo(1, 2) & " " & tablo(1, 3)    'pour tester
End Sub
merci @eriiiic pour la piqûre de rappel
 

Eivor

XLDnaute Nouveau
Bonjour à tous,
Je me permets de rebondir sur le sujet, étant débutant je tente de mettre en place un userform qui permettrait en fonction de filtre multicritères d'extraire des colonnes discontinues d'une listbox dynamique.
Pour ce faire je me suis appuyer sur les Tuto Boisgontiers.
l'userform s'alimente nikel, problème lorsque je veux programmer mon bouton d'extraction, une erreur type 13 apparait.

VB:
Private Sub UserForm_Initialize()
On Error Resume Next
  NomTableau = "Tableau1"
  TblBD = Range(NomTableau).Value
  NbCol = UBound(TblBD, 2)
  Set d = CreateObject("scripting.dictionary")
  For i = LBound(TblBD) To UBound(TblBD)
    d(TblBD(i, 9)) = ""
  Next i
  Me.ChoixListBox1.List = d.keys
  Set d = CreateObject("scripting.dictionary")
  For i = LBound(TblBD) To UBound(TblBD)
    d(TblBD(i, 6)) = ""
  Next i
  Me.ChoixListBox2.List = d.keys
  Set d = CreateObject("scripting.dictionary")
  d.comparemode = vbTextCompare
  For i = LBound(TblBD) To UBound(TblBD)
    d(TblBD(i, 10)) = ""
  Next i
  Me.ChoixListBox3.List = d.keys
  Me.ListBox1.ColumnCount = NbCol + 1
  Me.ListBox1.List = TblBD
  Range(NomTableau).ClearFormats
  EnteteListBox
End Sub


Private Sub ChoixListBox1_change()
  Affiche
End Sub
Private Sub ChoixListBox2_change()
  Affiche
End Sub
Private Sub ChoixListBox3_change()
  Affiche
End Sub
Sub Affiche()
  Set dchoisis1 = CreateObject("Scripting.Dictionary")
  For i = 0 To Me.ChoixListBox1.ListCount - 1
    If Me.ChoixListBox1.Selected(i) Then dchoisis1(Me.ChoixListBox1.List(i, 0)) = ""
  Next i
  Set dchoisis2 = CreateObject("Scripting.Dictionary")
  For i = 0 To Me.ChoixListBox2.ListCount - 1
    If Me.ChoixListBox2.Selected(i) Then dchoisis2(Me.ChoixListBox2.List(i, 0)) = ""
  Next i
  Set dchoisis3 = CreateObject("Scripting.Dictionary")
  For i = 0 To Me.ChoixListBox3.ListCount - 1
    If Me.ChoixListBox3.Selected(i) Then dchoisis3(Me.ChoixListBox3.List(i, 0)) = ""
  Next i
  n = 0: Dim Liste()
  For i = LBound(TblBD) To UBound(TblBD)
     tmp = TblBD(i, 9)
     tmp2 = TblBD(i, 6)
     tmp3 = TblBD(i, 10)
     If (dchoisis1.exists(tmp) Or dchoisis1.Count = 0) _
        And (dchoisis2.exists(tmp2) Or dchoisis2.Count = 0) _
          And (dchoisis3.exists(tmp3) Or dchoisis3.Count = 0) Then
         n = n + 1
         ReDim Preserve Liste(1 To NbCol + 1, 1 To n)
         For k = 1 To NbCol
            Liste(k, n) = TblBD(i, k)
         Next k
         Liste(k, n) = i
     End If
  Next i
  If n > 0 Then
    Me.ListBox1.Column = Liste
    Range(NomTableau).ClearFormats
    For i = 0 To Me.ListBox1.ListCount - 1
      ligne = Me.ListBox1.List(i, NbCol)
      Range(NomTableau).Cells(ligne, 1).Resize(, NbCol).Interior.ColorIndex = 4
    Next i
  Else
    Me.ListBox1.Clear
  End If
 
  Me.txtnbreco.Value = Me.ListBox1.ListCount
End Sub


L'erreur apparait sur ce bout de code (dernière ligne) :
Code:
Private Sub recu_Click()

Application.ScreenUpdating = False
  Set f = Sheets("EXTRACTION")
  n = ListBox1.ListCount
  Tbl = Me.ListBox1.List
  f.[A2].Resize(100000, NbCol + 1).ClearContents
  f.[A2].Resize(n, 13) = Application.Index(Tbl, Evaluate("Row(1:" & n & ")"), Array(1, 3, 6, 2, 4, 5, 7, 8, 9, 10, 11, 12, 13))
 
End Sub

Sur le fichier que je joint en titre d'exemple cela fonctionne, cependant lorsque j'exécute le code sur mon fichier de travail , l'erreur 13 apparait, si quelqu'un à une idée pour résoudre le probleme je suis preneur.

Merci d'avance
 

Pièces jointes

  • test-fichier-light.xlsm
    111.9 KB · Affichages: 11

Discussions similaires

Statistiques des forums

Discussions
311 724
Messages
2 081 936
Membres
101 844
dernier inscrit
pktla