Rechercher un nom dans une liste dans les cellules et plus

Bonjour.

Je sèche sur une ou plusieurs formules permettant d'afficher une donnée dans une colonne face à un nom. Je précise :

- une feuille "BDD" rassemble des données provenant d'un formulaire rempli chaque semaine. Celui-ci renseigne des participants à une thématique à une certaine date.

PARTICIPANTS //THEMATIQUE //Date

Paul, Jacques, Francis //TH1 //01/01/2000

Eric, Mathieu, Victor //TH2 //02/01/2000

Paul, Mathieu, Eric //TH3 //03/01/2000

Hector, Francis, Mathieu //TH4 //04/01/2000

- une feuille "SUIVI" permet d'afficher les thématiques suivies par participant.

-> je souhaite sur une feuille de suivi, qu'un tableau se remplisse automatiquement en fonction des infos de BDD.

-> les PARTICIPANTS sont listés dans les lignes de la colonne A et les THEMATIQUES dans la ligne 1

-> exemple : je souhaite que si Paul a suivi la thématique TH3, que dans le SUIVI s'affiche dans la colonne où apparaît TH3 et sur la ligne de Paul, la date correspondante.

Document de travail accessible via le lien suivant :

https://drive.google.com/open?id=1tDV6tywTuZ6a4yKjqESDRdM15y7CXMgToc6kAir7mLQ

Je remercie d'avance ceux qui pourront m'aider.

Cdlt

Salut Chirod,

quelque chose comme ça ?

Le code est dans le module VBA de la feuille 'BDD'.

Un double-clic démarre la macro, résultats en 'SUIVI'.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tSplit, iRow%, iRowT%, iCol%
'
Cancel = True
'
iRow = Range("A" & Rows.Count).End(xlUp).Row
With Worksheets("SUIVI")
    .Cells.Delete
    iRowT = 2
    .Range("B1").Resize(1, iRow - 1).Value = WorksheetFunction.Transpose(Range("A2:A" & iRow))
    For x = 2 To iRow
        .Range("A" & iRowT).Resize(UBound(Split(Range("B" & x), ", ")) + 1, 1).Value = WorksheetFunction.Transpose(Split(Range("B" & x), ", "))
        iRowT = .Range("A" & Rows.Count).End(xlUp).Row + 1
    Next
    .Range("A:A").RemoveDuplicates Columns:=1
    iRowT = .Range("A" & Rows.Count).End(xlUp).Row
    iCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range("A2:A" & iRowT).Sort key1:=.Range("A2"), order1:=xlAscending, Orientation:=xlByRows
    .Range("A1:" & Chr(64 + iCol) & iRowT).Borders.LineStyle = xlContinuous
    .Range("A1:" & Chr(64 + iCol) & iRowT).BorderAround Weight:=xlMedium
    .Range("B2:" & Chr(64 + iCol) & iRowT).Interior.ColorIndex = 45
    .Range("B2:" & Chr(64 + iCol) & iRowT).NumberFormat = "dd/mm/yyyy"
    For x = 2 To iRow
        tSplit = Split(Range("B" & x), ", ")
        For y = 0 To UBound(tSplit)
            .Cells(.Columns(1).Find(what:=tSplit(y), lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext).Row, _
                    .Rows(1).Find(what:=Cells(x, 1), lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext).Column) = Cells(x, 3)
        Next
    Next
    .Columns.AutoFit
    .Activate
End With
'
Application.ScreenUpdating = True
'
End Sub

A+