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

iliess

XLDnaute Occasionnel
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()
VB:
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
 

Pièces jointes

  • CreerTableauAPartirCellulesVisibles.xlsm
    73.3 KB · Affichages: 4
Solution
Bonsoir @iliess :),

Essayez donc ce code :
VB:
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...

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonsoir @iliess :),

Essayez donc ce code :
VB:
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
 

Pièces jointes

  • iliess- créer ARRAY tableau filtré- v1.xlsm
    79.4 KB · Affichages: 6
Dernière édition:

ChTi160

XLDnaute Barbatruc
Bonjour le Fil
En partant du très bon travail de @mapomme
Une autre approche !
VB:
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
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
312 820
Messages
2 092 410
Membres
105 410
dernier inscrit
TahYou-K3n