Try this :-
NB:- See code comments for "Lookup column" and "Results column"
Sub MG24Feb15
Dim Rng As Range, Dn As Range, n As Long, Dic As Object, c As Long
Dim col As Long, rCol As String
rCol = "C" 'Change "rCol" to the Results column
col =  6 'Change lookup "Col" to the required Offets Column Number (6="G")
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(, col).Value
    Else
        If Not InStr(Dic(Dn.Value), Dn.Offset(, col).Value) > 0 Then
            Dic(Dn.Value) = Dic(Dn.Value) & ";" & Dn.Offset(, col)
        End If
    End If
Next
With Sheets("Sheet1")
Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
End With
c = 1
With Sheets("Sheet3")
.Cells(1, 1) = "Reference": .Cells(1, rCol) = "Results"
For Each Dn In Rng
    If Dic.exists(Dn.Value) Then
        c = c + 1
        .Cells(c, 1) = Dn.Value: .Cells(c, rCol) = Dic(Dn.Value)
    End If
Next Dn
End With

End Sub
Regards Mick