شكرا لك اخي احمد هذا هو المطلوب ولكن تبقى مشكلة الاسماء المركبة ياريت حد يعمل حل للمشكلة
ياريت اخي احمد تضيف الكود التالي الى الكود الموجود الذي عملته من اجل حل مشكلة الاسماء المركبة
Function kh_Names(FullName As String, ParamArray iNdex1()) As String
Dim i As Integer
Dim kh_Split, MyArray, Ar
Dim Kh_String As String, Sn As String, Re As String
On Error GoTo Err_Kh_Names
'======================================
MyArray = Array("عبد ", "أبو ", "ابو ", "آل " _
, " الله", " الدين", " الإسلام", " الاسلام", " الحق")
'======================================
Sn = Application.WorksheetFunction.Trim(FullName)
For Each Ar In MyArray
Re = Replace(Ar, " ", "^")
Sn = Replace(Sn, Ar, Re)
Next
'======================================
kh_Split = Split(Sn, " ", , vbTextCompare)
On Error Resume Next
For i = 0 To UBound(iNdex1)
Kh_String = Kh_String & " " & kh_Split(iNdex1(i) - 1)
Next
On Error GoTo 0
Kh_String = Replace(Trim(Kh_String), "^", " ")
kh_Names = Kh_String
Exit Function
Err_Kh_Names:
kh_Names = ""
End Function