Microsoft 365 Tablo ( Array) avec colonnes discontinues

[Regueiro]

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

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]

Bonsoir le fil, Regueiro

Test OK avec un ListObject
(ici dans l'exemple A1:F20)

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]

Bonsoir Regueiro, JM,

Au post #1 Regueiro désire créer une fonction donc voyez le fichier joint et ces codes :

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+

 

[Regueiro]

Bonsoir le Forum, staple1600, job75.
Merci pour votre retour.
Voici le code plus court.

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]

Re

OK alors ma version raccourcie de ma version du message#2

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]

Je trouve que l'idée de la fonction était intéressante mais bon si l'on n'a pas de suite dans les idées...

 

[job75]

Bonjour Regueiro, JM,

Voici tout de même la fonction avec 2 arguments, le 2ème déterminant le choix des colonnes :

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+

 

[patricktoulon]

bonsoir
voila une fonction comme je les aime propre et nette @job75 pas de blabla

 

[patricktoulon]

re
une version spécial listobject l'array des colonnes est obtenu par leur nom

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

 

[Regueiro]

Bonsoir Le Forum.
Merci à tous pour vos contributions.
Job75 merci pour la Fonction
Bonne soirée

 

[Eivor]

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.

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) :

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