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

T

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
sylvanu
thespeedy20 à dit:
A chaque nouveau nom, nouvelle feuille ! une feuille unique par personne !
Cliquez pour agrandir...
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.
Trier par date Trier par votes
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
Pour avancer :
1- Comme dit au post #4 :
Ensuite je n'ai rien compris du remplissage de TabloR.
Cliquez pour agrandir...
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.
 
Vote positif 0 Vote négatif
T

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
 
Vote positif 0 Vote négatif
sylvanu

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.
 
Vote positif 0 Vote négatif
T

thespeedy20

XLDnaute Occasionnel
re,

sylvanu à dit:
1- Comme dit au post #4 :
Ca n'a pas changé. Je ne comprends toujours pas.
Cliquez pour agrandir...
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...


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

sylvanu à dit:
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.
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re,
thespeedy20 à dit:
si je change les ET en OU, les résultats sont totalement différents...ils collent les données des autres feuilles...
Cliquez pour agrandir...
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.
 
Vote positif 0 Vote négatif
T

thespeedy20

XLDnaute Occasionnel
re,

sylvanu à dit:
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 ?
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
sylvanu

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
Vote positif 0 Vote négatif
sylvanu

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.
 
Vote positif 0 Vote négatif
T

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
 
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
thespeedy20 à dit:
A chaque nouveau nom, nouvelle feuille ! une feuille unique par personne !
Cliquez pour agrandir...
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:
Vote positif 0 Vote négatif
Solution

Discussions similaires

T
  • Résolu(e)
XL 2016 macro et feuille protégé
2
Réponses
18
Affichages
506
laurent950
laurent950
BenHarber
  • Question
Microsoft 365 Tester l'existence d'un filtre dans un tableau structuré
2
Réponses
19
Affichages
729
TooFatBoy
TooFatBoy
I
  • Résolu(e)
Microsoft 365 Placer un tableau VBA dans un tableau structuré Excel
Réponses
14
Affichages
459
mapomme
mapomme
A
  • Question
insertion d'une ligne automatique dans un tableau excel.
Réponses
1
Affichages
236
sylvanu
sylvanu
patricktoulon
  • Question
Autres la fonction similaire
Réponses
11
Affichages
357
patricktoulon
patricktoulon
N
  • Question
Microsoft 365 Recherche dans un tableau structuré à partir d'une TextBox
Réponses
11
Affichages
268
NONO14
N
N
  • Résolu(e)
Microsoft 365 Transfère de données d'un Userform vers un tableau structuré d'une feuille de calcul
Réponses
4
Affichages
170
NONO14
N
A
  • Question
Insérer un copier / coller
Réponses
0
Affichages
280
aziz
A
chaelie2015
  • Question
XL 2013 Réduire un code
Réponses
0
Affichages
470
chaelie2015
chaelie2015
S
  • Question
XL 2013 recherche intuitif semi automatique dans Combobox (trié et avec valeur unique) inseré en UserForm VBA
2
Réponses
18
Affichages
917
Sghaier Chafaa
S

Membres actuellement en ligne

3 membres et 66 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 708
Messages
2 112 097
Membres
111 416
dernier inscrit
philipperoy83