Microsoft 365 Tablo ( Array) avec colonnes discontinues

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

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

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)

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

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

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

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

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