Extraire plusieurs données pour un critère et les concaténés.

[ckurt]

Bonjour,
J'aurai besoin d'aide.
J'ai deux tableaux différents (sous deux onglets), et j'aimerai extraire des données de ces deux tableaux dans un autre, selon un critère.
En souhaitant également concaténer si les résultats sont multiples.
La fonction recherchev ne me sert pas vu qu'elle ne ramène qu'un résultat.

Je vous joint un exemple de mon fichier.
Merci de votre aide.

 

[mapomme]

Re : Extraire plusieurs données pour un critère et les concaténés.

Bonsoir ckurt et bienvenue sur XLD

Avec une fonction personnalisée (je ne connais pas de formule permettant de concaténer un nombre variable et inconnu à l'avance d'expressions)

Function Concat(Source As Range, Critere, ColCritere&, colAextraire) As String

• Source est le tableau source où on fait la recherche et l'extraction.
• Critère est la valeur à rechercher
• ColCritere est le numéro de la colonne du tableau source où critère sera recherché
• colAextraire est le numéro de la colonne du tableau source des données à extraire

Le code de la fonction est dans le module VBA "module1":

Function Concat(Source As Range, Critere, ColCritere&, colAextraire) As String
Dim Tablo, i&
Tablo = Source.Value
For i = LBound(Tablo) To UBound(Tablo)
  If Tablo(i, ColCritere) = Critere Then Concat = Concat & "+" & Tablo(i, colAextraire)
Next i
If Left(Concat, 1) = "+" Then Concat = Mid(Concat, 2)
End Function

nota: juste pour l'exemple, j'ai utilisé une référence différente de Source pour la cellule verte (tableau source à trois colonnes), alors que pour les cellules en bleu, j'ai utilisé le tableau à deux colonnes (évidemment les résultats sont identiques puisque les valeurs ColCritere et colAextraire ont été adaptées en conséquence)

 

[Robert]

Re : Extraire plusieurs données pour un critère et les concaténés.

Bonjour Ckurt et bienvenu, bonjour Mapomme, bonjour le forum,

Uen autre proposition puisque j'y ai planché dessus...

Sub Macro1()
Dim r As Object 'déclare la variable r (onglet Résultat)
Dim d As Object 'déclare la variable d (Dictionnaire)
Dim o As Byte 'déclare la variable o (Onglets)
Dim dl As Integer 'déclare la variable dl (Dernière Ligne)
Dim pl(1 To 2) As Range 'déclare le tableau de variables indexées pl (PLages)
Dim cel As Range 'déclare la variable cel (CELlule)
Dim plc As Range 'déclare la variable plc (PLage des Critères)
Dim celv As Range 'déclare la variable celv (CELlule Visible)
Dim tc As String 'déclare la variable tc (Texte Concatené)

Set r = Sheets("résultat") 'définit l'onglet r
r.UsedRange.Offset(1, 0).Clear 'efface d'éventuelles anciennes données dans l'onglet r
Set d = CreateObject("Scripting.Dictionary") 'définit le dictionnaire d
For o = 1 To 2 'boucle dur les deux premiers onglets du classeur
    With Sheets(o) 'prend en compte l'onglet de la boucle
        dl = .Cells(Application.Rows.Count, o).End(xlUp).Row 'définit la dernière ligne éditée dl de la colonne o
        Set pl(o) = .Range(.Cells(2, o), .Cells(dl, o)) 'définit la plage pl(o) de l'onglet
        For Each cel In pl(o) 'boucle sur toutes les cellules cel de la plage pl(o)
            d(cel.Value) = "" 'alimente le dictionnaire
        Next cel 'prochaine cellule de la boucle
    End With 'fin de la prise en compte de l'onglet de la boucle
Next o 'prochain onglet de la boucle

r.Range("A2").Resize(d.Count) = Application.Transpose(d.keys) 'renvoie les valeurs uniques (sans doublon) du dictionnaire d
dl = r.Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée dl de la colonne 1 (=A) de l'onglet r
Set plc = r.Range("A2:A" & dl) 'définit la plage des critères
For o = 1 To 2 'boucle 1 : sur les deux premiers onglets du classeur
    For Each cel In plc 'boucle 2 : sur tous les critères de la plage plc
        'filtre la colonne o de l'onglet de la boucle 1 avec la valeur de cel comme critère
        Sheets(o).Range("A1").AutoFilter Field:=o, Criteria1:=cel.Value
        On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
        'boucle 3 sur toutes les cellules visibles de l'onglet filtré (génère une erreur si aucune cellule visible)
        For Each celv In pl(o).Offset(0, 1).SpecialCells(xlCellTypeVisible)
            If Err <> 0 Then Err = 0: GoTo suite 'si une erreur a été générée, annule l'erreur, va à l'étiquette "suite"
            tc = IIf(tc = "", celv.Value, tc & "+" & celv.Value) 'définit le text concatené tc
        Next celv 'prochaine celluile visible de la boucle 3
        cel.Offset(0, o).Value = tc: tc = "" 'renvoie le texte tc dans l'onglet r à o colonnes à droite de cel
suite: 'étiquette
        Sheets(o).Range("A1").AutoFilter 'supprime le filtre automatique
   Next cel 'prochaine cellule de la boucle 2
Next o 'prochain onglet de la boucle 1
End Sub