عزل الأسماء التي لا تحتوي اسم أب عن التي تحتوي إسم أب

[م. فراس الكيلاني]

السلام عليكم
لدي ملف الإكسيل المرفق
أريد كود ينفذ ما يلي:
1- عزل الأسماء التي لديها اسم اب عن التي ليس لديها اسم أب بحيث تكون الخانات بعد العزل مقترنة بالرقم المرفق معها قبل العزل وموضوعة لوحدها
2- عزل الخانات الفارغة عن الخانات المليئة بحيث تكون الخانات بعد العزل مقترنة بالرقم المرفق معها قبل العزل وموضوعة مع الخانات التي تنتج عن الطلب 1
 وشكرااا جزيلللا

 

New Microsoft Excel Worksheet.rar

[م. فراس الكيلاني]

أنا لدي هذا الكود ولكنه يقوم فقط بعزل الأسماء ووضعها في خانات جديدة
اي انا لا يقوم بعزل الخانات الفارغة
وفي الحالتين السابقتين ( عزل الأسماء الفارغة والغير فارغة ) لا يقوم بوضع الرقم المرفق بعد العزل
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

[سليم حاصبيا]

عسى ان يكون المطلوب

Sans paternal.rar

[م. فراس الكيلاني]

عسى ان يكون المطلوب

شكرا لمجهودك

ولكنه ليس المطلوب :-(

لا اريد من الكود أن يقوم بإزالة اسم الأب

اريده أن يضع  في العمودين الجديدين الأسماء التي كانت أصلا بلا اسم أب أو الأسماء التي كانت خاناتها فارغة في العمود الجديد مقترنة بنفس الرقم الذي كان في الخانة المجاورة لها من العمود المجاور

 

[م. فراس الكيلاني]

هذه صورة تمثل الذي أطلبه من الكود
 

[ياسر خليل أبو البراء]

أخي الفاضل

من المفترض أن ترفق ملف به الكود المراد التعديل عليه حتى تسهل على إخوانك ..

عموماً .... حصل خير

إليك الكود التالي عله يفي بالغرض

Sub ExtractTwoNames()
    Dim Rng As Range, Cell As Range
    Dim lRow As Long
    Dim AWF
    
    Set Rng = Range("B2:B" & Cells(Rows.Count, 1).End(3).Row)
    Set AWF = Application.WorksheetFunction
    lRow = 2

    Application.ScreenUpdating = False
        For Each Cell In Rng
            If kh_Names(AWF.Trim(Cell.Value), 1) = AWF.Trim(Cell.Value) Or kh_Names(AWF.Trim(Cell.Value), 1, 2) = AWF.Trim(Cell.Value) Then Cells(lRow, 4) = Cell.Offset(, -1): Cells(lRow, 5) = 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

تقبل تحياتي

Extract Single & Double Names V2 YasserKhalil.rar

[سليم حاصبيا]

تم التعديل على الملف حسب ما تريد

انظر الى الصفحة الثانية واضغط افضل اجابة (اذا كانت كذلك)

Sans paternal adapte.rar

[م. فراس الكيلاني]

تم التعديل على الملف حسب ما تريد

انظر الى الصفحة الثانية واضغط افضل اجابة (اذا كانت كذلك)

شكرا لك أخي لكن الكود الذي أرفقته انت لا يقوم بعمل عزل لأكثر من 39 سطر

لقد حصلت على الذي أريده من اجابة الأخ ياسر

أكرر شكري لك

[سليم حاصبيا]

تستطيع ان تعدل المعادلات باستبدال للرقم 40 بأي رقم تريده

[م. فراس الكيلاني]

تستطيع ان تعدل المعادلات باستبدال للرقم 40 بأي رقم تريده

هذا الشيء( امر التعديل ) أعرفه... ولكن أحببت أن انوه لك

شكرا