Try this:-
Sub MG15Feb50
Dim Rng As Range, Dn As Range, n As Long, Dic As Object, c As Long
With Sheets("Sheet2")
Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
End With
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For Each Dn In Rng
    If Not Dic.exists(Dn.Value) Then
        Dic.Add Dn.Value, Dn.Offset(, 1).Value
    Else
        If Not InStr(Dic(Dn.Value), Dn.Offset(, 1).Value) > 0 Then
            Dic(Dn.Value) = Dic(Dn.Value) & ";" & Dn.Offset(, 1)
        End If
    End If
Next
With Sheets("Sheet1")
Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
End With
ReDim Ray(1 To Rng.Count + 1, 1 To 2)
Ray(1, 1) = "Reference": Ray(1, 2) = "Results"
c = 1
For Each Dn In Rng
    If Dic.exists(Dn.Value) Then
        c = c + 1
        Ray(c, 1) = Dn.Value: Ray(c, 2) = Dic(Dn.Value)
    End If
Next Dn
With Sheets("Sheet3").Range("A1").Resize(c, 2)
    .Value = Ray
    .Columns.AutoFit
    .Borders.Weight = 2
End With
End Sub
Regards Mick