Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("G2")) Is Nothing And Target.Count = 1 Then
    On Error Resume Next
    Dim arr(), I&, J&, iDic As Object
    arr = Me.ListObjects(1).DataBodyRange
    Set iDic = CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(arr)
        For J = 3 To UBound(arr, 2)
            If arr(I, J) = Target Then iTemp = iDic(arr(I, 1))
        Next
    Next
    Application.EnableEvents = False
    With Range("H2").Validation
        .Delete
        .Add Type:=xlValidateList, Formula1:=Join(iDic.Keys, ",")
    End With
    Range("H2") = Empty
End If
Application.EnableEvents = True
End Sub