XL 2016 VBA Synthèse classeur suivant recherche

[scalaze]

Bonsoir,

J'ai un classeur composé de feuille de "ville" avec différentes données structurer de la même manière.
Je souhaiterais sur la feuille Synthèse et suivant le critère de recherche en O2, se trouvant en colonne G, effectuer une synthèse sur l'ensemble des feuilles.
J'ai essayé quelques codes ou autre trouver sur le forum mais 😞
Je ne suis pas expert en la matière et je ne sais pas par ou commencer.

Pouvez vous m'aider à solutionner ma problématique ou m'aiguiller?

Merci d'avance.

 

[sylvanu]

Bonjour Scalaze,
Un essai en PJ avec :

Sub Cherche()
On Error GoTo Fin
    Dim Reference, IndexW%, IndexR%, C%, Sh As Worksheet
    Application.ScreenUpdating = False
    Sheets("SYNTHESE").Range("A2:L1000").ClearContents
    ' Recherche Ref
    Reference = Sheets("SYNTHESE").Range("O1")
    IndexW = 2
    ' Pour toutes les feuilles
    For Each Sh In ThisWorkbook.Worksheets
        If Sh.Name <> "SYNTHESE" Then  ' Exclusion feuille Synthèse
            With Sheets(Sh.Name)
                If Not IsError(Application.Match(Reference, .Range("G:G"), 0)) Then
                    IndexR = Application.Match(Reference, .Range("G:G"), 0)
                    For C = 1 To 12 ' puisque 12 valeurs à copier
                        Sheets("SYNTHESE").Cells(IndexW, C) = .Cells(IndexR, C)
                    Next C
                    IndexW = IndexW + 1
                End If
            End With
        End If
    Next Sh
Fin:
End Sub

 

[Robert]

Bonjour Scalaze, Sylvanu, bonjour le forum

Il est trop rapide ce Sylvanu !... 😛
C'est dans le même esprit avec juste l'événementielle Change au lieu du bouton et une liste de validation de données en O1.
Les codes :
• Onglet SYNTHESE :

Private Sub Worksheet_Activate() 'a l'activation de l'onglet
Module1.ListValid 'lance la procédure [ListValid] du module [Module1]
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)

If Target.Address <> "$O$1" Then Exit Sub 'si le changement à lieu ailleurs qu'en O1, sort de la procédure
Range("A1").CurrentRegion.Offset(1, 0).ClearContents 'efface les éventuelles anciennes valeurs
If Target.Value = "" Then Exit Sub 'si O1 est effacée, sort de la procédure
For Each O In Sheets 'boucle 1 : sur tous les ongelts O du classeur
    If O.Name <> Me.Name Then 'condition 1 : si l'onglet n'est pas "SYNTHESE"
        TV = O.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
        For I = 2 To UBound(TV, 1) 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
            If CStr(TV(I, 7)) = CStr(Target.Value) Then 'condition 2 : si la donnée ligne I colonne I de TV est égale à la valeur de O1
                K = K + 1 'incrémente K
                ReDim Preserve TL(1 To UBound(TV, 2), 1 To K) 'redimensionne le tableau des lignes TL (autant de ligne que TV a de colonnes, K colonnes)
                For J = 1 To UBound(TV, 2) 'boucle 3 : sur toutes les colonnes J du tableau des valeurs TV
                    TL(J, K) = TV(I, J) 'récupère dans la ligne J de TL la donnée en colonne J de TV (=> transposition)
                Next J 'prochaine colonne de la boucle 3
            End If 'fin de la condition 2
        Next I 'prochaine ligne de la boucle 2
    End If 'fin de la condition 1
Next O 'prochain onglet de la boucle 1
Range("A2").Resize(K, UBound(TV, 2)).Value = Application.Transpose(TL) 'renvoie le tableau TL transposé dans A2 redimensionnée
Me.Columns("I:J").NumberFormat = "0" 'format des colonne I et J
End Sub

• ThisWorkbook :

Private Sub Workbook_Open()
Module1.ListValid 'lance la procédure [ListValid] du module [Module1]
End Sub

• Module1 :

Sub ListValid()
Dim D As Object 'déclare la variable D (Dicionnaire)
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim L As String 'déclare la variable L (Liste)

Set D = CreateObject("Scripting.Dictionary") 'définit la dictionnaire D
For Each O In Sheets 'boucle 1 : sur tous les ongelts O du classeur
    If O.Name <> "SYNTHESE" Then 'condition 1 : si l'onglet n'est pas "SYNTHESE"
        TV = O.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
        For I = 2 To UBound(TV, 1) 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
            D(TV(I, 7)) = "" 'alimente le dictionnaire D avec les données en colonne 7 de TV
        Next I 'prochaine ligne de la boucle 2
    End If 'fin de la condition 1
Next O 'prochain onglet de la boucle 1
TMP = D.keys 'récupère dans le tableau temporaire TMP la liste des élément du dictionnaire D sans doublon
L = Join(TMP, ",") 'définit la liste L
With Sheets("SYNTHESE").Range("O1").Validation 'prend en compte la validation de donnée de la cellule O1 de l'onglet "SYNTHESE"
    .Delete 'éfface une éventuelle validation de données existante
    .Add xlValidateList, Formula1:=L 'définit la liste L comme liste de validation de données
End With 'fin de la prise en compte de la validation de donnée de la cellule O1 de l'onglet "SYNTHESE"
End Sub

Le fichier :

 

[scalaze]

Bonjour Sylvanu et Robert

Tout d'abord ,merci pour l'aide et travail effectué suite à ma demande.

Concernant vos deux propositions , j'ai une petite préférence à celle de Sylvanu
même si la tienne Robert fonctionne a merveille .

La problématique est que j'aurai + de 20 000 réf sur chaque feuille et je me vois pas dérouler la liste de validation donc la fonction recherche est plus approprier à moins que tu es une meilleur idée .

Quoi qu' il en soit , je garde vos deux travail bien au chaud ,pour application et étude ultérieure du code.

Reste plus à appliquer sur le fichier "Origine" , je vous tiens au courant....


Encore un énorme MERCI à vous deux.

Bien cordialement

A bientôt

Scalaze

 

[Hasco]

Bonjour,

Dans le classeur joint et parce que @scalaze a une version 2016 ou pour ceux que ça intéresse, une proposition par Power Query.

Les grilles de données ont été transformées en Tableaux structurés nommés par le nom de la ville et préfixés de "Donnees_"

La cellule contenant la référence à chercher a été nommée "PrmRéf2" pour servir de paramètre à la requête. Cette dernière est rafraîchie sur changement du paramètre.

Cordialement

 

[scalaze]

Rebonjour, Sylvanu , Robert
Bonjour Roblochon,

Apres test sur le fichier de base , je me suis aperçu que la proposition de Sylvanu n'affiché pas la totalité des références présente dans chaque ville.

j ai oublié de dire que les références recherchées peuvent être sur plusieurs ligne.
j ai modifié le fichier avec comme exemple la référence 12324965 qui apparait plusieurs fois dans les différentes villes.

La proposition de Robert , elle m'affiche bien la référence 12324965 ,
le problème sans en être un , est la liste de validation pour choisir la référence recherche par rapport à ma base.

je ne sais pas si il est possible de "concaténer " vos deux solution par rapport à ma demande.


Reblochon, merci pour votre proposition


Bien cordialement

Scalaze

 

[sylvanu]

Rebonjour Scalaze , Robert, Roblochon,
Oups! Je n'avais pas vu qu'il pouvait y en avoir plusieurs par page.🙄
Un nouvel essai en PJ à vérifier.

 

[scalaze]

Bonjour sylvanu

Vérifié et adopté.

Encore un énorme MERCI à toi ,ainsi à Roblochon et Robert.

A bientôt sur le forum

Bien cordialement


Scalaze