Microsoft 365 remplir un tableau Arr() en vba à partir des cellules visible

[iliess]

bonjour
je cherche a remplir mon Arr en vba à partir des cellules visible d'une plage

voici mon code mais je suis coinser dans deux pint
* comment conter le nombre des ligne visible
*comment remplir le tableau Arr()

Option Explicit
Sub CreerTableauAPartirCellulesVisibles()
    Dim plageVisible As Range
    Dim cellule As Range
    Dim Arr() As Variant
    Dim i As Integer
      
    Set plageDeDonnees = Sheets("GrandLivre").Range("A3:G1000")
     
    plageDeDonnees.SpecialCells(xlCellTypeVisible).Select
       
    Set plageVisible = Selection
       
    ReDim Arr(1 To 26, 1 To 6)
   
    ' Remplir le tableau avec les valeurs des cellules visibles
    For Each cellule In plageVisible
        i = i + 1
        Arr(1, i) = cellule.Value
    Next cellule
       
End Sub

 

[mapomme]

Bonsoir @iliess 🙂,

Essayez donc ce code :

Sub CreerTableauAPartirCellulesVisibles()
Dim TS As ListObject, xrg As Range, arr, xarea, t
Dim max As Long, i As Long, n As Long, j As Long

   Set TS = Sheets("GrandLivre").Range("a2").ListObject
   On Error Resume Next
   Set xrg = TS.DataBodyRange.SpecialCells(xlCellTypeVisible)
   On Error GoTo 0
   If Not xrg Is Nothing Then
      For Each xarea In xrg.Areas: max = max + xarea.Rows.Count: Next xarea
      ReDim arr(1 To max, 1 To TS.ListColumns.Count)
      For Each xarea In xrg.Areas
         t = xarea.Value
         For i = 1 To UBound(t)
            n = n + 1
            For j = 1 To TS.ListColumns.Count: arr(n, j) = t(i, j): Next j
         Next i
      Next xarea
   End If
  
   'affichage en A1 de la feuille Résultat pour vérification
   Sheets("Résultat").Range("a1").CurrentRegion.Clear
   If max > 0 Then Sheets("Résultat").Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
   Application.Goto Sheets("Résultat").Range("a1"), True
End Sub

 

[iliess]

Bonjour
Merci beaucoup mr @mapomme
C'est exactement ce que je cherche.
Un très joli travail

 

[ChTi160]

Bonjour le Fil
En partant du très bon travail de @mapomme
Une autre approche !

Sub CreerTableauAPartirCellulesVisibles()
Dim TS As ListObject, xrg As Range, arr, xarea, t
Dim max As Long, i As Long, n As Long, j As Long
Dim DerLgn As Long
   Set TS = Sheets("GrandLivre").Range("a2").ListObject
   On Error Resume Next
   Set xrg = TS.DataBodyRange.SpecialCells(xlCellTypeVisible)
   On Error GoTo 0
   If Not xrg Is Nothing Then
   With Sheets("Résultat")
               .Range("a2").Resize(10000, 6).Clear
      For Each xarea In xrg.Areas
         t = xarea.Value
         DerLgn = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                  .Cells(DerLgn, 1).Resize(UBound(t), UBound(t, 2)) = t
      Next xarea
    End With
   End If
   Application.Goto Sheets("Résultat").Range("a1"), True
End Sub

Bonne Journée
Jean marie

 

[iliess]

Merci beaucoup mr @ChTi160
Un joli travail
Cordialement