Maybe:
Function removeSpecial(sInput As String) As String
Dim sSpecialChars As String
Dim i As Long
sSpecialChars = ",;"
For i = 1 To Len(sSpecialChars)
sInput = Replace$(sInput, Mid$(sSpecialChars, i, 1), "")
Next
removeSpecial = sInput
End Function
Sub SearchNames()
Dim FstLstRng As Range, rCell As Range, CheckCells As Range
Dim NameList As Variant, Nme As Variant
Dim Str As String, a As Long, b As Long, c As Long
Set FstLstRng = Range("G2:H" & Range("G" & Rows.Count).End(xlUp).Row).Cells
Set CheckCells = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Cells
NameList = FstLstRng
For Each rCell In CheckCells.Cells
rCell.Offset(, 1).Value = "CHECK"
Str = removeSpecial(rCell.Value)
Nme = Split(Str, " ")
For a = 0 To UBound(Nme)
For b = 1 To UBound(NameList)
If UCase(Nme(a)) = UCase(NameList(b, 1)) Then
For c = 0 To UBound(Nme)
If UCase(Nme(c)) = UCase(NameList(b, 2)) Then
rCell.Offset(, 1).Value = NameList(b, 1)
rCell.Offset(, 2).Value = NameList(b, 2)
Exit For
End If
Next c
End If
Next b
Next a
For a = 0 To UBound(Nme)
For b = 1 To UBound(NameList)
If UCase(Nme(a)) = UCase(NameList(b, 2)) Then
For c = 0 To UBound(Nme)
If UCase(Nme(c)) = UCase(NameList(b, 1)) Then
rCell.Offset(, 1).Value = NameList(b, 1)
rCell.Offset(, 2).Value = NameList(b, 2)
Exit For
End If
Next c
End If
Next b
Next a
Next rCell
End Sub