XL 2019 Utiliser lignes d'un filtre d'un tableau structuré dans un tableau

thespeedy20

XLDnaute Occasionnel
Bonsoir le Forum,

Je filtre mon tableau structuré, ici en l'occurrence , le résultat est de 3 lignes.. l'adressage est bon mais je n'arrive pas à mettre ces 3 lignes dans mon tableau...

VB:
Sub TransfertDCI()     'tranfert de données pour avis

     Dim Compteur As Integer, a As Integer
     Dim tabloR(), tablo
     Dim FDep  As Worksheet: Set FDep = Worksheets("Données")
     Dim Farr  As Worksheet: Set Farr = Worksheets("Débition_Caution_Ind")
     Dim ws  As Worksheet
     Dim LR1 As Long, LR2 As Long
     Dim plage_filtre, x&
  
  
     Application.ScreenUpdating = False
    
      
    
     With FDep
    
    .[A1].AutoFilter 9, "30"
    Set plage_filtre = .[_FilterDataBase]
    x = plage_filtre.Rows.Count - 1
    
    tablo = plage_filtre.Offset(1, 0).Resize(x).SpecialCells(12).Value
    'MsgBox plage_filtre.Offset(1, 0).Resize(x).SpecialCells(12).Address
    
     End With
    
    
          For a = 1 To UBound(tablo) Step 1 '10 noms par fois
          ReDim tabloR(29, 1 To 4) 'vider tabloR
          For Compteur = 0 To 0
               If a + Compteur > UBound(tablo) Then Exit For
               r = Compteur * 2
               tabloR(r, 1) = tablo(a + Compteur, 1) & " " & tablo(a + Compteur, 2)
               tabloR(r + 2, 1) = tablo(a + Compteur, 3)
               tabloR(r + 4, 1) = tablo(a + Compteur, 4) & " à " & tablo(a + Compteur, 5) & " " & tablo(a + Compteur, 6)
              
          Next

          Farr.Range("B33").Resize(UBound(tabloR), UBound(tabloR, 2)) = tabloR
          Farr.Range("C40") = "MONTANT"
          Farr.Range("C42") = "30"
          
                  
    
    
For Each ws In ActiveWorkbook.Worksheets
   If ws.Name <> "Données" And ws.Name <> "DCI" And ws.Name <> "DLI" Then
        LR1 = Sheets("DCI").Range("A" & Rows.Count).End(xlUp).Row
        LR2 = ws.Range("A" & Rows.Count).End(xlUp).Row
        ws.Range("A1:G" & LR2).Copy Destination:=Sheets("DCI").Range("A" & LR1 + 1)
        
   End If
Next ws



     Next
 

  

Application.ScreenUpdating = False
End Sub

Je vous en remercie par avance

OLi
 

Pièces jointes

  • Avis_copie_V2B_individuel.xlsm
    42.2 KB · Affichages: 25
Solution
A chaque nouveau nom, nouvelle feuille ! une feuille unique par personne !
Ca, fallait le comprendre.
Alors à quoi sert donc votre "For Each ws In ActiveWorkbook.Worksheets" puisque vous collez dans DCI ?

Pour trois valeurs à coller, il est plus rapide de coller directement dans la feuille plutôt que de créer un TabloR , le rempli, puis le transférer.

Un essai en PJ. Chaque ligne visible remplit une feuille Débition_Caution_Ind qui est copiée à la queue leuleu dans DCI.

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re,
En fait tablo est vide.
J'ai remplit Tableau1 avec :
VB:
    With FDep
        .[A1].AutoFilter 9, "30"
        Lig = 0
        For N = 2 To [Tableau1].Rows.Count
            If .Cells(N, "A").Rows.Hidden = False Then
                For i = 1 To 9
                    tablo(Lig, i - 1) = .Cells(N, i)
                Next i
                Lig = Lig + 1
            End If
        Next N
    End With
"tablo" est remplit des données des lignes visibles.
Il faudra pour TabloR juste vérifier que If tablo(N, 0) <> "" Then ...

Ensuite je n'ai rien compris du remplissage de TabloR.
Si vous le dimensionner à 29 lignes, alors le collage se fera sur 29 lignes. Au vu de la feuille où s'est coller, je ne pense pas que cela soit correct.

Dernier point qui n'a rien à voir :
Code:
If ws.Name <> "Données" And ws.Name <> "DCI" And ws.Name <> "DLI" Then
ne peut pas marcher car une feuille ne peut pas s'appeler Nom1 ET Nom2 ET Nom3.
Tentez plutôt :
Code:
If ws.Name <> "Données" Or ws.Name <> "DCI" Or ws.Name <> "DLI" Then
on ne travaille que sur les feuilles qui s'appelent Nom1 OU Nom2 OU Nom3
 

thespeedy20

XLDnaute Occasionnel
re, Sylvanu

merci pour ton code :

pour le remplissage "Tablo" , j'ai une erreur incompatibilité de type (erreur 13) sur la ligne :

VB:
tablo(Lig, I - 1) = .Cells(N, I)

le but c'est de créer une feuille (Débition_Caution_ind) par ligne de la base filtrée Données et les copiés dans une autre feuille (DCI), les unes à la suite des autres....
J 'espère que c'est plus clair pour toi ce que j'essaie de faire...

OLi
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Oups,
J'ai oublié de copier une ligne, celle qui dimensionne tablo :
VB:
    ReDim tablo([Tableau1].Rows.Count, 10)
    With FDep
        .[A1].AutoFilter 9, "30"
        Lig = 0
        For N = 2 To [Tableau1].Rows.Count
            If .Cells(N, "A").Rows.Hidden = False Then
                For i = 1 To 9
                    tablo(Lig, i - 1) = .Cells(N, i)
                Next i
                Lig = Lig + 1
            End If
        Next N
    End With
 

thespeedy20

XLDnaute Occasionnel
re,

ce n'est pas grave...;)

Par contre, je ne n'ai pas le résultat voulu...j'ai toujours une vingtaine de feuilles qui se créent... et la première ligne du filtre n'est pas reprise à la sortie...(j'ai changé N = 2 par N=1 et là j'ai première ligne)

Je suis complètement perdu là...🤪

OLi
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Avez vous bien utilisé un IF pour filtre tablo ? comme dit au post #4 :
Il faudra pour TabloR juste vérifier que If tablo(N, 0) <> "" Then ...
car tablo est initialisé avec une longueur égale au tableau de la feuille.
Mais seules les lignes dont tablo(N, 0) <> "" sont visibles, il faut donc s'arrêter dès que tablo(N, 0) = "".
( NB on peut réduire la taille du tablo avec ReDim tablo([Tableau1].Rows.Count, 8)
Ne pas oublier que le tablo commence en 0,0.
Voilà ce que cela donne avec votre fichier :
1655739722474.png
 
Dernière édition:

thespeedy20

XLDnaute Occasionnel
re,

comme ceci :

VB:
For a = 1 To UBound(tablo) 
          ReDim tabloR(29, 1 To 4)
          '
               If a > UBound(tablo) Then Exit For
               If tablo(a, 0) <> "" Then
                                    
               r = 2
               tabloR(r, 1) = tablo(a, 1) & " " & tablo(a, 2)
               tabloR(r + 2, 1) = tablo(a, 3)
               tabloR(r + 4, 1) = tablo(a, 4) & " à " & tablo(a, 5) & " " & tablo(a, 6)
              
               Farr.Range("B33").Resize(UBound(tabloR), UBound(tabloR, 2)) = tabloR
               Farr.Range("C40") = "MONTANT"
               Farr.Range("C42") = "30"
    
    
               Else
    
               Exit Sub
          
          
            
              End If
 

Discussions similaires

Réponses
11
Affichages
236