CERCA.VERT CON RISULTATI MULTIPLI

Option Explicit

Sub riporta()
Dim ur1 As Long, ur2 As Long, i As Long, j As Long, tutte As String
    'assume ultima riga col.B
    ur1 = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
    Range("B5:B" & ur1).Copy 'copia l'intervallo
    Range("J5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    'elimina i duplicati
    ActiveSheet.Range("$J$5:$J$" & ur1).RemoveDuplicates Columns:=1, Header:=xlNo
    'assume ultima riga col.J
    ur2 = ActiveSheet.Cells(Rows.Count, 10).End(xlUp).Row
    'esegue un doppio ciclo; il primo confronta i dati tabella, il secondo i dati subgruppo
    For i = 5 To ur2
        tutte = ""
        For j = 5 To ur1
            If Cells(i, 10) = Cells(j, 2) Then
                tutte = tutte & Cells(j, 3) & ";"
            End If
        Next j
        Cells(i, 11) = tutte
    Next i
    Cells(1, 1).Select
End Sub

Function Riporta1(a As Range, rng As Range)
Dim cel As Range
Dim stringa As String
For Each cel In rng
    If cel.Value = a.Value Then
        Riporta1 = Riporta1 & cel.Offset(0, 1).Value & "; "
    End If
Next cel
End Function

=riporta1(E8;$B$8:$B$18)

=riporta1(E8;$B$8:$B$18)

Function Riporta1(a As Range, rng As Range)
Dim cel As Range
Dim stringa As String
For Each cel In rng
    If cel.Value = a.Value Then
        Riporta1 = Riporta1 & cel.Offset(0, 1).Value & " " & cel.Offset(0, 2).Value & "; "
    End If
Next cel
End Function