اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


إذهب إلى أفضل إجابة Solved by ياسر خليل أبو البراء,

الردود الموصى بها

السلام عليكم
لدي ملف الإكسيل المرفق
أريد كود ينفذ ما يلي:
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
رابط هذا التعليق
شارك

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

شكرا لمجهودك

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

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

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

 

رابط هذا التعليق
شارك

  • أفضل إجابة

أخي الفاضل

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

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

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

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

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

Extract Single & Double Names V2 YasserKhalil.rar

  • Like 1
رابط هذا التعليق
شارك

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

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

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

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

أكرر شكري لك

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information