XL 2016 Reporter des lignes de plusieurs feuilles

[Bz1]

Bonjour, je ne sais pas si c'est possible en tout cas je l'espère car j'aime automatiser les choses le plus possible. Je souhaite reporter dans un tableau les lignes de plusieurs feuilles et doubler certaines selon un critère. Ce n'est pas évident à faire comprendre comme ça... J'ai illustré dans la dernière feuille le résultat souhaité. Et je voudrais que les lignes continuent à s'ajouter dans le tableau si je rajoute des lignes dans les autres feuilles. Merci d'avance

 

[job75]

Bonjour Bz1,

Voyez le fichier joint et cette macro dans le code de la feuille "Résultat" (clic droit sur l'onglet et Visualiser le code) :

Private Sub Worksheet_Activate()
Dim col, d As Object, w As Worksheet, P As Range, t, j%, a, b, ub%, i&, n&, resu()
col = Array("B", "C") 'liste des colonnes, à adapter
Set d = CreateObject("Scripting.Dictionary")
For Each w In Worksheets
    If w.Name <> Me.Name Then
        Set P = w.[A1].CurrentRegion
        t = P.Resize(P.Rows.Count + 1) 'matrice, plus rapide, au moins 2 éléments
        For j = 1 To UBound(t, 2)
            If IsNumeric(Application.Match(t(1, j), col, 0)) Then d(t(1, j)) = j 'mémorise la colonne
        Next j
        If d.Count Then
            a = d.keys: b = d.items: ub = UBound(a)
            For i = 2 To UBound(t) - 1
                For j = 0 To ub
                    If t(i, b(j)) <> "" Then
                        n = n + 1
                        ReDim Preserve resu(1 To 3, 1 To n)
                        resu(1, n) = t(i, 1)
                        resu(2, n) = a(j)
                        resu(3, n) = t(i, b(j))
                    End If
            Next j, i
            d.RemoveAll 'RAZ du Dictionary
        End If
    End If
Next w
If n Then
    '---transposition---
    ReDim t(1 To n, 1 To 3)
    For i = 1 To n
        For j = 1 To 3
            t(i, j) = resu(j, i)
    Next j, i
    '---restitution---
    If FilterMode Then ShowAllData 'si la feuille est filtrée
    [A2].Resize(n, 3) = t
End If
[A2].Offset(n).Resize(Rows.Count - n - 1, 3).ClearContents 'RAZ sous le tableau
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Elle se déclenche quand on active la feuille.

A+

 

[job75]

Re,

Au cas où vous n'auriez pas bien compris : les titres "B" et "C" peuvent être dans n'importe quelle colonne (après la 1ère).

Bonne nuit.

 

[Bz1]

Tout d'abord merci pour ta réponse @job75 . Je n'ai jamais utiliser de macro, comment activer la feuille "Résultat" stp ?

Cordialement

 

[job75]

Bonjour Bz1, le forum,

Je n'ai jamais utiliser de macro, comment activer la feuille "Résultat" stp ?

1. Quand on déplace la souris on voit se déplacer sur l'écran un petit objet en forme de croix (le curseur).

2. Amener le curseur sur "Résultat" en bas de la feuille : le curseur se transforme en flèche.

3. Appuyer avec l'index sur le bouton gauche de la souris (quand on est droitier), cela s'appelle cliquer.

Evidemment c'est moins facile quand on n'a pas de souris

A+

 

[Bz1]

Bonjour, c'est bon. En fait, il suffisait de cliquer sur le bouton "activer les macros", je n'avais pas vu le message de sécurité C'est super ce que tu as fait, c'est exactement ce que je voulais je ne pensais même pas que c'était possible à mettre en place... ça donne envie d'apprendre le macro ! Peux-tu refaire la même chose mais sur ce fichier stp car je n'arrive pas complétement à transposer le truc sur mon projet personnel. Merci infiniment @job75 , ce forum est génial ^^

 

[job75]

Re,

Pour bien faire j'ai ajouté les variables colLibel et colDate dans le fichier joint :

Private Sub Worksheet_Activate()
Dim col, d As Object, w As Worksheet, P As Range, colLibel As Variant, colDate As Variant, t, j%, a, b, ub%, i&, n&, resu()
col = Array("F", "G", "H", "I") 'liste des colonnes, à adapter
Set d = CreateObject("Scripting.Dictionary")
For Each w In Worksheets
    If w.Name <> Me.Name Then
        Set P = w.[A1].CurrentRegion
        colLibel = Application.Match("Libellé", P.Rows(1), 0)
        colDate = Application.Match("Date", P.Rows(1), 0)
        t = P.Resize(P.Rows.Count + 1) 'matrice, plus rapide, au moins 2 éléments
        For j = 1 To UBound(t, 2)
            If IsNumeric(Application.Match(t(1, j), col, 0)) Then d(t(1, j)) = j 'mémorise la colonne
        Next j
        If d.Count Then
            a = d.keys: b = d.items: ub = UBound(a)
            For i = 2 To UBound(t) - 1
                For j = 0 To ub
                    If t(i, b(j)) <> "" Then
                        n = n + 1
                        ReDim Preserve resu(1 To 4, 1 To n)
                        If IsNumeric(colDate) Then resu(1, n) = t(i, colDate) Else resu(1, n) = ""
                        If IsNumeric(colLibel) Then resu(2, n) = t(i, colLibel) Else resu(2, n) = ""
                        resu(3, n) = a(j)
                        resu(4, n) = t(i, b(j))
                    End If
            Next j, i
            d.RemoveAll 'RAZ du Dictionary
        End If
    End If
Next w
If n Then
    '---transposition---
    ReDim t(1 To n, 1 To 4)
    For i = 1 To n
        For j = 1 To 4
            t(i, j) = resu(j, i)
    Next j, i
    '---restitution---
    If FilterMode Then ShowAllData 'si la feuille est filtrée
    [A2].Resize(n, 4) = t
End If
[A2].Offset(n).Resize(Rows.Count - n - 1, 4).ClearContents 'RAZ sous le tableau
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub

A+

 

[Bz1]

Merci encore et bonne continuation à toi

 

[Bz1]

Dernière question : si j'ajoute par la suite des feuilles, que dois-je rajouter dans le code pour que la feuille soit incluse dans le tableau "Résultat" ?

 

[job75]

Dernière question : si j'ajoute par la suite des feuilles, que dois-je rajouter dans le code pour que la feuille soit incluse dans le tableau "Résultat" ?

Rien, vous auriez pu tester non ?

 

[Bz1]

Ah oui... j'avais testé mais j'avais oublié de mettre au moins un chiffre dans l'une des colonnes F, G, H, I. J'ai modifié la formule de la colonne K (feuille 1 mais je compte la faire aussi sur les 2 autres feuilles) et ça me mets ce message d'erreur, la macro ne fonctionne plus :
"Erreur d'exécution '1004'
Erreur définie par l'application ou par l'objet"
Merci d'avance pour ton aide.

 

[job75]

Re,

Cela fait 10 ans que je suis sur ce forum et c'est la 1ère fois que je vois ça !!!

Copier la formule de la colonne L jusqu'à la dernière ligne de Feuil1 (1048576) c'est vraiment incroyable.

C'est pour cela que le fichier pèse 10 Mo.

Au moins effacez toute la ligne 1048576, il n'y aura plus de bug.

A+

 

[Bz1]

Ouais, j'ai effacé tout ce qui suit après la ligne n°2000 car ça beugait et que ça me suffit largement. Je savais pas que ça augmentait à ce point là la taille du fichier. Merci, à bientôt.