Option Explicit

Sub give_data()
  Dim D As Object
  Dim S As Worksheet
  Dim S_rg As Range, Trg As Range
  Dim Ro%, y, m%, itm

  Set D = CreateObject("Scripting.Dictionary")
  Set S = Sheets("Sheet2")
  Set S_rg = S.Range("A1").CurrentRegion.Columns(2)
  Set S_rg = S_rg.Offset(1).Resize(S_rg.Rows.Count - 1)
  Set Trg = S.Range("F1").CurrentRegion

If Trg.Rows.Count > 1 Then Trg.Offset(1) _
.Resize(Trg.Rows.Count - 1).ClearContents
Ro = 1
 Do Until Ro > S_rg.Rows.Count
    If S_rg.Cells(Ro) <> vbNullString Then
        If Not D.Exists(S_rg.Cells(Ro).Value) Then
          D(S_rg.Cells(Ro).Value) = _
          S_rg.Cells(Ro).Offset(, 1).Value
        Else
          D(S_rg.Cells(Ro).Value) = _
          D(S_rg.Cells(Ro).Value) & "*" _
          & S_rg.Cells(Ro).Offset(, 1).Value
        End If
     End If
    Ro = Ro + 1
 Loop
  m = 2
 For Each y In D.keys
  Cells(m, "F") = y
  itm = Split(D(y), "*")
    Cells(m, "G").Resize(, UBound(itm) + 1) = itm
   m = m + 1
 Next
  With Cells(2, "E").Resize(m - 2)
    .Formula = "=INDEX(A1:A" & Ro & _
     ",MATCH(F2,B1:B" & Ro & ",0))"
    .Value = .Value
  End With
  
  Set D = Nothing: Set S = Nothing
  Set S_rg = Nothing: Set Trg = Nothing

End Sub

=IF(B5="","",IF(COUNTIF($B$2:B4,B5)>=1,INDEX($A$2:A4,MATCH(B5,$B$2:B4,0)),""))

Sub Sch_Cods()
Dim i As Long
Dim j As Long
Dim LR As Long
Dim ws As Worksheet
Dim Arr As Variant
Dim Sch As String
Dim Cnt As Integer
Application.ScreenUpdating = False
Set ws = Sheets("Sheet2")
LR = ws.Range("B" & Rows.Count).End(xlUp).Row
Arr = ws.Range("A2:B4").Value
For j = 1 To UBound(Arr, 1)
Sch = Arr(j, 2)
Cnt = Arr(j, 1)
i = 2
Do While i <= LR
If ws.Cells(i, 2) = Sch Then
ws.Cells(i, 1) = Cnt
End If
i = i + 1
Loop
Next
Application.ScreenUpdating = True
End Sub

Sub Sal_Cods()
Dim LR As Long
Dim ws As Worksheet
Dim i%, N
Application.ScreenUpdating = False
 Set ws = Sheets("Sheet2")
LR = ws.Range("B" & Rows.Count).End(xlUp).Row

For i = 5 To LR
 Select Case Cells(i, 2)
    Case Cells(2, 2): N = Cells(2, 1)
    Case Cells(3, 2): N = Cells(3, 1)
    Case Cells(4, 2): N = Cells(4, 1)
    Case Else: N = ""
  End Select
 Cells(i, 1) = N
Next

Application.ScreenUpdating = True
End Sub

Sub Test()
    Dim a, dic As Object, i As Long
    Set dic = CreateObject("Scripting.Dictionary")
    For i = 2 To 4
        dic.Add Cells(i, 2).Value, Cells(i, 1).Value
    Next i
    a = Range("A5:B" & Cells(Rows.Count, 2).End(xlUp).Row).Value
    For i = LBound(a) To UBound(a)
        a(i, 1) = dic(a(i, 2))
    Next i
    Range("A5").Resize(UBound(a)).Value = a
End Sub