Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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
Pour avancer :
1- Comme dit au post #4 :
Ensuite je n'ai rien compris du remplissage de TabloR.
Ca n'a pas changé. Je ne comprends toujours pas.

2- Avez vous modifié le point concernant les ET en OU du post #4.

3- dans votre fichier vous faites :
VB:
For a = 1 To UBound(tablo) Step 1 '10 noms par fois
  ReDim tabloR(29, 1 To 4) 'vider tabloR
donc vous réinitialisez votre array à chaque tour de a.
Ne devrait on pas avoir plutôt :
Code:
ReDim tabloR(29, 1 To 4) 'vider tabloR
For a = 1 To UBound(tablo) Step 1 '10 noms par fois
où il n'est initialisé qu'au départ.

4- Voici le code. A la ligne "ReDim tabloR(29)" l'array tablo est correct, comme déjà dit.
Pourquoi avoir créer un array TabloR de dimension 4 si vous n'utilisez que l'indice 1. Autant faire TabloR(29).
D'autant que pour le collage cela ne fera pas la même chose. Vous allez essayer de coller 4 colonnes.

VB:
Sub TransfertDCI()     'tranfert de données pour avis
     Dim Compteur%, a%, LR1&, LR2&, plage_filtre, x&, 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
    Application.ScreenUpdating = False
    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
        ReDim tabloR(29) 'vider tabloR
        For a = 1 To UBound(tablo) Step 1          '10 noms par fois
          If tablo(a, 1) <> "" Then                 ' si array colonne 1 est vide on ne fait rien

            ' Mettre ici le code pour filtrer'
            
          End If

          Farr.Range("B33").Resize(UBound(tabloR), UBound(tabloR, 2)) = tabloR  ' Vous collez 4 colonnes ?
          Farr.Range("C40") = "MONTANT"
          Farr.Range("C42") = "30"

    Next
Application.ScreenUpdating = False
End Sub

Essayez de tester sans la dernière partie, avec votre filtre. tant que ça ça ne marche pas inutile d'aller plus loin.
 

thespeedy20

XLDnaute Occasionnel
Re,

VB:
Sub DCI()

     Dim 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 sTableau As String
     Dim loTableau As ListObject
    
    Application.ScreenUpdating = False
    
      
    ReDim tablo([Tableau1].Rows.Count, 10)
          
      
    With FDep
        .[A1].AutoFilter 9, "30"
        Lig = 0
        For N = 1 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
    
     ReDim tabloR(29, 1 To 4)
     For a = 1 To UBound(tablo)
          'vider tabloR
          
               If a > UBound(tablo) Then Exit For
               If tablo(a, 0) <> "" Then
              
               r = 0
               tabloR(r, 1) = tablo(a, 0) & " " & tablo(a, 1)
               tabloR(r + 2, 1) = tablo(a, 2)
               tabloR(r + 4, 1) = tablo(a, 3) & " à " & tablo(a, 4) & " " & tablo(a, 5)
              
          

               Farr.Range("B33").Resize(UBound(tabloR), UBound(tabloR, 2)) = tabloR
               Farr.Range("C40") = "MONTANT"
               Farr.Range("C42") = "30"
               Farr.Range("A52") = "X"
               Else
    
               Sautdepage
              
               sTableau = "Tableau1"
               Set loTableau = FDep.ListObjects(sTableau)
 
               loTableau.AutoFilter.ShowAllData
              
                              
              
               Exit Sub
          
          
              
               End If
              
                 
    

For Each ws In ActiveWorkbook.Worksheets
   If ws.Name <> "Données" And ws.Name <> "DCI" And ws.Name <> "DLI" And ws.Name <> "Débition_Location_Ind" 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


Application.CutCopyMode = False

 
     Next
 
Application.ScreenUpdating = False
End Sub

Ce code fonctionne avec ReDim tabloR(29, 1 To 4)...

J'ai essayé avec ReDim tabloR(29), je ne suis jamais arrivé à le faire fonctionner, j'avais un problème sur cette ligne : Farr.Range("B33").Resize(UBound(tabloR), UBound(tabloR, 2)) = tabloR

OLi
 

sylvanu

XLDnaute Barbatruc
Supporter XLD

Farr.Range("B33").Resize(UBound(tabloR), UBound(tabloR, 2)) = tabloR
C'est le transfert d'un tablo à plusieurs dimensions: UBound(tabloR) et UBound(tabloR, 2)
Pour un tableau à une dimension faites :
VB:
Farr.Range("B33").Resize(UBound(tabloR), 1).Value = Application.Transpose(tabloR)

Mais en fait, vous ne répondez jamais aux questions. Donc on n'avancera pas.
Donc c'est inutile de continuer.
 

thespeedy20

XLDnaute Occasionnel
re,

1- Comme dit au post #4 :
Ca n'a pas changé. Je ne comprends toujours pas.
J'ai repris l'idée d'une macro que j'ai trouvé sur le net afin de tester les tableaux, et je n'en sais pas plus malheureusement...


2- Avez vous modifié le point concernant les ET en OU du post #4.
si je change les ET en OU, les résultats sont totalement différents...ils collent les données des autres feuilles...

j'ai effectué le changement et c'est vrai que c'est plus logique.

je vais essayer de répondre aux questions avec le plus de précisions possibles.

OLi
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re,
si je change les ET en OU, les résultats sont totalement différents...ils collent les données des autres feuilles...
Oui j'ai dit une sottise. Simple réflexe de Pavlov.
Habituellement je fais :
VB:
If ws.Name = "Données" Or ws.Name = "DCI" Or ws.Name = "DLI" Then
Mais c'est exacetement la même chose que :
Code:
If ws.Name <> "Données" And ws.Name <> "DCI" And ws.Name <> "DLI" Then


Deux points que je ne comprends pas :

1- Cette partie de votre code :
Code:
If a > UBound(tablo) Then Exit For
If tablo(a, 0) <> "" Then
r = 0
tabloR(r, 1) = tablo(a, 0) & " " & tablo(a, 1)
tabloR(r + 2, 1) = tablo(a, 2)
tabloR(r + 4, 1) = tablo(a, 3) & " à " & tablo(a, 4) & " " & tablo(a, 5)
Qu'est ce que c'est censé faire ?
D'autant qu'à chaque boucle vous faites r=0 donc vous ne remplissez que tabloR(0,1), (2,1) et (4,1).
( si même r évoluait, vous n'écrieriez qu'une ligne sur 2 dans l'array. Pourquoi ? )
Ensuite votre :
Code:
Farr.Range("B33").Resize(UBound(tabloR), UBound(tabloR, 2)) = tabloR
va coller ses valeurs en B33:E62 ( 62=33+29 )
Or, dans cette zone vous avez des informations. Vous allez tout détruire.
Un coller array colle TOUT l'array, et non pas seulement les case utilisées.
Donc il va faire du genre : Range("B33:R62)=tabloR.
Et là je ne comprend plus.
 

thespeedy20

XLDnaute Occasionnel
re,

Le but, c'était de prendre les données filtrées, et les insérés dans une feuille et répéter l'opération autant de fois que de données...

Les données sur chaque feuille doivent se trouver

En B33 : nom + prénom
En B35 : date de naissance
En B37 : adresse + code postal + localité

Voilà pourquoi, écrire une ligne sur deux...

Chaque feuille étant collée l'une à la suite de l'autre...

le filtre peut-être appliquer sur la location ou la caution...

OLi
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour,
En PJ un essai, et vous verrez que ça ne peut pas marcher.
1- On ne remplit que de B33 à B37, dans ce cas on boucle tant que tablo(x,1)<>"" mais on ne tranefère évidemment que le dernier visible
2- On remplit tabloR avec toutes les données visibles et alors le tableau fait ici 18 lignes ( 3*6 ) et alors le collage se fait de B33 à B49. Dans ce cas ce n'est plus compatible de Débition_Caution_Ind
La PJ1 traite le cas 1. La PJ2 le cas 2.
Vous verrez que dans les deux cas il y a un souci.
( NB J'ai supprimé la fin de la macro car elle est en dehors du problème )
 

Pièces jointes

  • Avis_copie_V2B_individuel (12).xlsm
    35.1 KB · Affichages: 4
  • Avis_copie_V2B_individuel (13).xlsm
    35.1 KB · Affichages: 3

thespeedy20

XLDnaute Occasionnel
Bonjour Sylvanu,

oui effectivement , dans les cas il y a un soucis...

Est-il possible alors de contourner ces problèmes et d'arriver à ce que je désirais faire...?

Autre méthode, autre approche ... ?

OLi
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour,
C'est impressionnant. Deux fois je vous ai demandé ce que vous vouliez faire, je n'ai pas eu de réponse claire, et vous me demandez s'il existe une autre solution pour résoudre votre problème.
Soyons clair, si vous pouviez répondre clairement aux questions :
Dans votre fichier vous avez trois lignes visibles, ce qui génèrent 18 lignes dans TabloR.
Que voulez vous faire de ces 18 lignes ?
Dans votre code, pour le For each, si vous excluez "Données" ,"DCI", et "DLI" il ne vous reste que Débition_Caution_Ind, où justement on vient de coller.
Désolé j'y comprends vraiment rien.
Alors mettez vos idées au clair sinon ça ne sert à rien de continuer.
 

thespeedy20

XLDnaute Occasionnel
re,

Je suis sincèrement désolé, je vais essayer de m'exprimer plus clairement...

Le but est de transférer nom - prénom - date de naissance et adresse complète sur le Débition_Caution_Ind de la façon suivante :

En B33 : nom + prénom
En B35 : date de naissance
En B37 : adresse + code postal + localité

Ce qui représente 6 lignes...

A chaque nouveau nom, nouvelle feuille ! une feuille unique par personne ! donc ici dans l'exemple, il doit générer 3 feuilles.(qui peut-être variable en fonction du filtre)

Ensuite coller l'ensemble des feuilles l'une derrière l'autre dans l'onglet DCI

OLi
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
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.
 

Pièces jointes

  • Avis_copie_V2B_individuel (V2).xlsm
    41.5 KB · Affichages: 6
Dernière édition:

thespeedy20

XLDnaute Occasionnel
re,

c'est exactement ce que je désirais... mille et une excuses pour mon manque de clarté...
Merci beaucoup Sylvanu

Ps : j'ai du remplacer Set Plage = Farr.[A1.G52] par Set Plage = Farr.[A1:G52] car j'avais une erreur d'incompatibilité...
 

ChTi160

XLDnaute Barbatruc
Bonsoir le fil
C'est peut être du au fait que tu as un point au lieu de 2 pour la définition de la plage (erreur)
Soit :
Farr.[A1.G52] ici un point
Faut
Farr.[A1:G52] la deux points
Jean marie
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…