سؤال عن كود لفرز محتويات عمود

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

السلام عليكم
لدي عمود واحد  فيه أسماء ثلاثية ( الإسم و اسم الأب والشهرة ) وأسماء ثنائية (الإسم والشهرة )
أريد نص برمجي يقوم بعزل الأسماء التي لايوجد فيها اسم الاب عن الأسماء التي يوجد فيها اسم الأب
وشكرا

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

أخي الكريم

ارفق ملف للإطلاع عليه ويا حبذا لو أرفقت بعض النتائج المتوقعة

تقبل تحياتي

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

شكرا لتواصلك
في الملف يوجد مثال عن الذي اريده
العمود الاول موجود فيه الأسما مع اسم االأب
العمود الثاني الأسماء بدون اسم الأب ( بعد الفرز )
لم يمكنني المستعرض من رفع الملف
هذه صورة مرفقة
 

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

شكرا لتواصلك

في الملف يوجد مثال عن الذي اريده

العمود الاول موجود فيه الأسما مع اسم االأب

العمود الثاني الأسماء بدون اسم الأب ( بعد الفرز )

لم يمكنني المستعرض من رفع الملف

هذه صورة مرفقة

 

طبعا اسماء الشهرة غير متشابهة والملف اكبر من الذي ارسلته في الصورة

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

أفهم من الصورة أنك تريد استثناء الأسماء الثنائية أي استخراجها في عمود منفصل ...

الملف المرفق سيسهل العمل والمساعدة .. اتعب شوية وارفق بعض الأسماء للعمل عليها لا يشترط كل الأسماء .. يكفي كما في الصورة المرفقة

اضغط الملف ثم قم برفعه

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

يا حبذا لو ترفع لي ملف اكسل  مضاف اليه الكود..لأنني لم اتعلم كيفية اضافة كود بعد :-(

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

هذا هو الملف

1.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

تقبل تحياتي  :fff:

لا تنسى أن تحدد أفضل إجابة وتضغط أعجبني (هتعمل حاجتين مش حاجة واحدة)

 

Extract Single & Double Names YasserKhalil.rar

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

جزاك الله كل خير
أليس من المفروض أن يعمل الكود لوحده في العمود الثاني؟
ماذا يجب أن أفعل بعد أن اقوم بفتح الملف المرفق؟
المفروض أنه يقوم بالفرز بشكل تلقائي ...لكنه لم يقم بذلك
هل يجب أن افعل شي؟
شكرا لك على وقتك
 

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

أخي الكريم الكود لا يعمل بشكل تلقائي يجب الضغط على زر الامر .. قم بكتابة الأسماء لديك كلها في العمود الاول ثم اضغط الزر

ألم ترى أن هناك زر مكتوب عليه قل : سبحان الله والحمد لله ولا إله إلا الله والله أكبر .. اضغط على الزر بعد ما تقول الذكر هتلاقي النتائج كما طلبت

إذا لم تكن ممكن الماكرو يجب عليك مشاهدة الفيديو التالي