أنا لدي هذا الكود ولكنه يقوم فقط بعزل الأسماء ووضعها في خانات جديدة
اي انا لا يقوم بعزل الخانات الفارغة
وفي الحالتين السابقتين ( عزل الأسماء الفارغة والغير فارغة ) لا يقوم بوضع الرقم المرفق بعد العزل
Sub ExtractTwoNames()
'يقوم الكود باستخراج الأسماء الفردية و الثنائية ويضع النتائج في العمود الثاني'----------------------------------------------------------------------------
Dim Rng As Range, Cell As Range
Dim lRow As Long
Set Rng = Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
lRow = 2
Application.ScreenUpdating = False
For Each Cell In Rng
If kh_Names(Trim(Cell.Value), 1) = Trim(Cell.Value) Or kh_Names(Trim(Cell.Value), 1, 2) = Trim(Cell.Value) Then Cells(lRow, 2) = Trim(Cell): lRow = lRow + 1
Next Cell
Application.ScreenUpdating = True
End Sub
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