=IF(LEN(B4)-LEN(SUBSTITUTE(B4," ",""))+1=4,B4,LEFT(B4,FIND("~",SUBSTITUTE(B4," ","~",4))))

Option Explicit

'         بسم الله الرحمن الرحيم            "
'         ********************           "

'       دالة استخراج اسم ولي الأمر         "
'========================================"
'     True =    kh_First  اذا كان        "
'        او اي رقم غير الصفر              "
'     تقوم باستخراج الاسم الاول            "
'========================================"
'    يامكانية معالجة الاسم المركب الاول      "
'    تلقائياً حسب  معايير معرفة لديها      "
'      Kh_Father_Replace  في الدالة       "
'       ويمكنك اضافة اي معيار آخر         "
'        بجانب المعايير الموجودة             "
'          MyArray  في المتغير              "
'      مع مراعاة وجود فراغ بداية
'           او نهاية المعيار
'========================================"
'-----------------------------------------------------------------

Function Kh_Father_Name(ByVal Name As String, Optional kh_First As Boolean) As String
Dim KhString As String, Kh_Mid As String, Kh_Rep  As String
Dim KhMyNo As Integer
    On Error GoTo Err_Kh_Father_Name
    If IsEmpty(Name) Then GoTo Err_Kh_Father_Name
    KhString = Kh_Father_Replace(Trim(Name)) & " "
    KhMyNo = InStr(1, KhString, " ", 1)
    If kh_First Then Kh_Mid = Trim(Mid(KhString, 1, KhMyNo)) Else _
    Kh_Mid = Trim(Mid(KhString, KhMyNo, Len(KhString)))
    Kh_Rep = Replace(Kh_Mid, "^", " ")
    Kh_Father_Name = Kh_Rep
        Exit Function
Err_Kh_Father_Name:
     Kh_Father_Name = ""
End Function
Private Function Kh_Father_Replace(ByVal Kh_Sub As String) As String
Dim MyArray, Ar
Dim Sn As String, Re As String
'====================================================
' يمكنك اضافة اي معيار آخر هنا بجانب المعايير الموجودة
MyArray = Array("عبد ", "أبو ", "ابو ", "آل ", " الله" _
    , " الدين", " الإسلام", " الاسلام", " الحق")
'====================================================
Sn = Kh_Sub
For Each Ar In MyArray
    Re = Replace(Ar, " ", "^")
    Sn = Replace(Sn, Ar, Re)
Next
Kh_Father_Replace = Sn
End Function
Function NoSpaces(InName As String) As String
Dim NewName As String, ThePrevStr As String, TheStr As String
Dim i As Integer
InName = Trim(InName)
For i = 1 To Len(InName)
    TheStr = Mid(InName, i, 1)
    If TheStr = " " And ThePrevStr = " " Then TheStr = ""
    If TheStr <> "" Then ThePrevStr = TheStr
    NewName = NewName & TheStr
Next
NoSpaces = NewName
End Function
Function PartsCount(InName As String) As Integer
If NoSpaces(InName) = "" Then Exit Function
Dim i As Integer, U As Integer
Do
    i = InStr(i + 1, InName, " ", 1)
    If i = 0 Then Exit Do Else U = i
Loop
PartsCount = U + 1
End Function
Function GoodPartOfName(InName As String, NumberOfPart As Integer) As String
'تستخدم هذه الدالة لتحديد الجزء المطلوب من الإسم
'وذلك عن طريق تحديد رقمه في NumberOfPart
'الاسم الاول = 1
'الثاني = 2
'.....وهكذا
Dim sCount As Integer, i As Integer, U As Integer, F As Long
Dim ThePart() As String, RealPart() As String
Dim SpecialNames() As String, SpecialKinds() As Byte, SpecialCounts As Long
Dim SpecialPart As Variant
InName = NoSpaces(Kh_Father_Replace(Trim(InName)) & " ")
If InName = "" Then Exit Function
sCount = PartsCount(InName)
If NumberOfPart > sCount Then Exit Function
If NumberOfPart < sCount Then sCount = sCount + 1
ReDim ThePart(1 To sCount)
ReDim RealPart(1 To sCount)
For i = 1 To sCount
    ThePart(i) = PartOfName(InName, i)
    If i = 1 Then
        SpecialPart = "'" & ThePart(i) & "'"
    Else
        SpecialPart = SpecialPart & "," & "'" & ThePart(i) & "'"
    End If
Next i
If SpecialCounts <> 0 Then
    i = 0
    ReDim SpecialNames(1 To SpecialCounts)
    ReDim SpecialKinds(1 To SpecialCounts)
End If
For i = 1 To sCount
SpecialPart = Null
If SpecialCounts <> 0 Then
    For F = 1 To SpecialCounts
        If ThePart(i) = SpecialNames(F) Then SpecialPart = SpecialKinds(F)
    Next F
End If
If IsNull(SpecialPart) Then
    U = U + 1
    RealPart(U) = ThePart(i)
ElseIf SpecialPart = 2 Then
    U = U + 1
    RealPart(U) = ThePart(i) & " " & ThePart(i + 1)
    i = i + 1
ElseIf SpecialPart = 1 Then
    If i = 1 Then
        U = U + 1
        RealPart(U) = ThePart(i)
    ElseIf InStr(1, RealPart(U), " ", 1) <> 0 Then
        U = U + 1
        RealPart(U) = ThePart(i)
    Else
        U = U
        RealPart(U) = RealPart(U) & " " & ThePart(i)
    End If
End If
Next i
GoodPartOfName = Replace(RealPart(NumberOfPart), "^", " ")
End Function
Function PartOfName(InName As String, NumberOfPart As Integer) As String
Dim TheSpaceNumber As Byte
Dim i As Integer, U As Integer
InName = NoSpaces(InName)
PartOfName = ""
If InName = "" Then Exit Function
Do
    U = i
    i = InStr(i + 1, InName, " ", 1)
    If i <> 0 Then
        TheSpaceNumber = TheSpaceNumber + 1
        If TheSpaceNumber = NumberOfPart Then Exit Do
    ElseIf TheSpaceNumber + 1 = NumberOfPart Then
        i = Len(InName) + 1
        Exit Do
    Else
        Exit Function
    End If
Loop
        PartOfName = Trim(Mid(InName, U + 1, i - U - 1))
End Function
Public Function StName(TheName As String)
'الاسم الأول
StName = GoodPartOfName(TheName, 1)
End Function
Public Function FatherName(TheName As String)
'اسم الأب
Dim MyFName As String
If Len(GoodPartOfName(TheName, 3)) > 0 Then
MyFName = GoodPartOfName(TheName, 2)
Else
MyFName = ""
End If
FatherName = MyFName
End Function
Public Function StGrndName(TheName As String)
'الجد الأول
Dim MyStGName As String
If Len(GoodPartOfName(TheName, 4)) > 0 Then
MyStGName = GoodPartOfName(TheName, 3)
Else
MyStGName = ""
End If
StGrndName = MyStGName
End Function
Public Function NdGrndName(TheName As String)
'الجد الثاني
Dim MyNdGName As String
If Len(GoodPartOfName(TheName, 5)) > 0 Then
MyNdGName = GoodPartOfName(TheName, 4)
Else
MyNdGName = ""
End If
NdGrndName = MyNdGName
End Function

=StName($B4)&" "& FatherName($B4)&" "&StGrndName($B4)&" "&NdGrndName($B4)

=IF(LEN(B4)-LEN(SUBSTITUTE(B4," ",""))+1=4,B4,LEFT(B4,FIND("~",SUBSTITUTE(B4," ","~",4))))