اذهب الي المحتوي
أوفيسنا

دالة توزيع الاسم على عدة حقول


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

السلام عليكم اخواني

ماهي الداله التي توزع الاسم الى ( الاسم  اسم الاب اسم الجد اسم الجد الثاني اللقب ) مع مراعاة

1- ان يكون الاخير هو اللقب اذا كان الاسم اقل من رباعي

2- الاسماء التي تتكون من شقين ك( عبد الرحمن  بن عثيمين  زين العابدين )

 

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

5 دقائق مضت, ياسر خليل أبو البراء said:

أخي الكريم عبد العزيز المدني

قم بضغط ملفك وإرفاقه ليتسنى للجميع تقديم المساعدة

تقبل تحياتي

تسلم استاذي العزيز ياسر خليل أبو البراء said على سرعة استجابتك وهذا الملف المرفق 2003 وللعلم اشتغل انا على اكسيل 2013

توزيع الاسم.rar

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

أخي الكريم عبد العزيز

إليك دالة معرفة تقوم بالأمر ونسبة نجاحها حوالي 95% .. الأمر لن يسلم من بعض الأخطاء البسيطة ...

توضع الدالة المعرفة في موديول جديد ..

Function Kh_Names(FullName As String, ParamArray Index1()) As String
    Dim I As Integer
    Dim Kh_Split, MyArray, Arr
    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 Arr In MyArray
        RE = Replace(Arr, " ", "^")
        SN = Replace(SN, Arr, 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

وإليك الملف المرفق فيه توضيح لكيفية استخدام الدالة

أرجو أن تفي بالغرض

تقبل تحياتي

 

Split Compound Names UDF Function.rar

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

منذ ساعه, ياسر خليل أبو البراء said:

أخي الكريم عبد العزيز

إليك دالة معرفة تقوم بالأمر ونسبة نجاحها حوالي 95% .. الأمر لن يسلم من بعض الأخطاء البسيطة ...

توضع الدالة المعرفة في موديول جديد ..


Function Kh_Names(FullName As String, ParamArray Index1()) As String
    Dim I As Integer
    Dim Kh_Split, MyArray, Arr
    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 Arr In MyArray
        RE = Replace(Arr, " ", "^")
        SN = Replace(SN, Arr, 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

وإليك الملف المرفق فيه توضيح لكيفية استخدام الدالة

أرجو أن تفي بالغرض

تقبل تحياتي

 

Split Compound Names UDF Function.rar

تسلم استاذي لكن الملف المرفق لايفتح

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

الحمد لله فتح الملف بس كان ثقيل مره  ولي استفسار

لكن هذا الكود لابد ان يكون الاسم رباعي وانا اريد حتى وان كان الاسم اثنين مثلا (محمد المدني ) فقط اريد ان يضع الاسم الاول في خانة الاسم والاخير دايما في اللقب

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

أخي الكريم عبد العزيز

جرب الكود التالي في وجود الدالة المعرفة ...

Sub TestRun()
    Dim I As Integer
    For I = 2 To Cells(Rows.Count, "B").End(xlUp).Row
        If Kh_Names(Cells(I, "B"), 1) = Cells(I, "B") Then
            Cells(I, "C") = Kh_Names(Cells(I, "B"), 1)
        ElseIf Kh_Names(Cells(I, "B"), 1, 2) = Cells(I, "B") Then
            Cells(I, "C") = Kh_Names(Cells(I, "B"), 1)
            Cells(I, "G") = Kh_Names(Cells(I, "B"), 2)
        ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3) = Cells(I, "B") Then
            Cells(I, "C") = Kh_Names(Cells(I, "B"), 1)
            Cells(I, "D") = Kh_Names(Cells(I, "B"), 2)
            Cells(I, "G") = Kh_Names(Cells(I, "B"), 3)
        ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3, 4) = Cells(I, "B") Then
            Cells(I, "C") = Kh_Names(Cells(I, "B"), 1)
            Cells(I, "D") = Kh_Names(Cells(I, "B"), 2)
            Cells(I, "E") = Kh_Names(Cells(I, "B"), 3)
            Cells(I, "G") = Kh_Names(Cells(I, "B"), 4)
        ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3, 4, 5) = Cells(I, "B") Then
            Cells(I, "C") = Kh_Names(Cells(I, "B"), 1)
            Cells(I, "D") = Kh_Names(Cells(I, "B"), 2)
            Cells(I, "E") = Kh_Names(Cells(I, "B"), 3)
            Cells(I, "F") = Kh_Names(Cells(I, "B"), 4)
            Cells(I, "G") = Kh_Names(Cells(I, "B"), 5)
        End If
    Next I
End Sub

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

أرجو أن يفي بالغرض

 

 

Split Compound Names UDF Function V2.rar

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

للعلم الكود الاول والملف الأول شغال ميه المية بس الثاني لا يوزع كل الاسماء

شكرا للمهندس الكبير ياسر بارك الله فيك وجعلك مباركا ورزقك من حيث لا تحتسب

 

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

أخي الكريم عبد العزيز قلم الإكسيل

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

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

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

هذه صورة خطأ المعادلة الثانية حيث ان بعض الاسماء لم تتوزع بعد الضغط على مفتاح run

 

خطأ المعادلة الثانية.png

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

أخي الكريم قلم الإكسيل

بارك الله فيك وجزيت خيراً على دعواتك الطيبة المباركة

بالنسبة للكود :::

------------------

أنا مجرب الكود بدل المرة ألف مرة لأني أستخدمه في برامجي الخاصة

تأكد من أنك لم تحذف أي شيء من الكود أو الدالة المعرفة ..

ضع الكود التالي بالكامل في موديول جديد ثم نفذ الأمر مرة أخرى

Sub TestRun()
    Dim I As Integer
    For I = 2 To Cells(Rows.Count, "B").End(xlUp).Row
        If Kh_Names(Cells(I, "B"), 1) = Cells(I, "B") Then
            Cells(I, "C") = Kh_Names(Cells(I, "B"), 1)
        ElseIf Kh_Names(Cells(I, "B"), 1, 2) = Cells(I, "B") Then
            Cells(I, "C") = Kh_Names(Cells(I, "B"), 1)
            Cells(I, "G") = Kh_Names(Cells(I, "B"), 2)
        ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3) = Cells(I, "B") Then
            Cells(I, "C") = Kh_Names(Cells(I, "B"), 1)
            Cells(I, "D") = Kh_Names(Cells(I, "B"), 2)
            Cells(I, "G") = Kh_Names(Cells(I, "B"), 3)
        ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3, 4) = Cells(I, "B") Then
            Cells(I, "C") = Kh_Names(Cells(I, "B"), 1)
            Cells(I, "D") = Kh_Names(Cells(I, "B"), 2)
            Cells(I, "E") = Kh_Names(Cells(I, "B"), 3)
            Cells(I, "G") = Kh_Names(Cells(I, "B"), 4)
        ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3, 4, 5) = Cells(I, "B") Then
            Cells(I, "C") = Kh_Names(Cells(I, "B"), 1)
            Cells(I, "D") = Kh_Names(Cells(I, "B"), 2)
            Cells(I, "E") = Kh_Names(Cells(I, "B"), 3)
            Cells(I, "F") = Kh_Names(Cells(I, "B"), 4)
            Cells(I, "G") = Kh_Names(Cells(I, "B"), 5)
        End If
    Next I
End Sub

Function Kh_Names(FullName As String, ParamArray Index1()) As String
    Dim I As Integer
    Dim Kh_Split, MyArray, Arr
    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 Arr In MyArray
        RE = Replace(Arr, " ", "^")
        SN = Replace(SN, Arr, 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

وهذه صورة من ورقة العمل بعد الضغط على الأمر Run

Untitled.png.39cd17bb5f95aa6e11de37c4390

ويمكن التأكد من عمل الكود من الأخوة الكرام الذين جربوا الملف الأخير

تقبل تحياتي

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

من لايشكر الناس لايشكر الله شكرا استاذنا

الكود عندي شغال تمام التمام وانا من امس احاول التعليق والرد وتقديم الشكر لاستاذنا ياسر خليل أبوالبراء فلم استطع تطلع لي رسايل لاتملك الصلاحيه لذلك

تم تعديل بواسطه عبدالعزيزالمدني
  • Like 1
رابط هذا التعليق
شارك

جزيت خيراً أخي الفاضل عبد العزيز المدني

والحمد لله أن تم المطلوب على خير .. كما نتمنى أن يعمل الكود لدى عبد العزيز الآخر (قلم الإكسيل) .. في انتظار محاولاته

 

أخي قلم الإكسيل ..

ما هي نسخة الأوفيس التي تعمل عليها؟

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

2016 النسخة الاحترافية

لكن ليست مشكلة المهم ان احد الاكواد عمل لدي

والشي الثاني ان صاحب الموضوع قد عمل لديه

شكرا لك المبدع العزيز المهندس ياسر على اهتمامك ورعايتك رعاك الله اينما كنت

المهندس ياسر اشتغل الكود بعد تغيير الاسماء الموجودة بالجدول المرفق

شكرا لك باركك الرحمن ولا تنسانا بإبداعاتك المتواصل جعل الله لك بكل حرف اجرا مثل جبال تهامة اللهم امين

تم تعديل بواسطه قلم-الاكسل(عبدالعزيز)
  • Like 1
رابط هذا التعليق
شارك

السلام عليم

استاذي العزيز بارك الله بجهودك وجزاك الله كل خير

هناك ملحوظة وهي انه اذا كان اسمين مركبين لا يعمل بشك صحيح مثلا:(عبد الله محمد سعيد أحمد العاني)

حيث:

الاسم عبد الله

اسم الاب محمد سعيد

اسم الجد أحمد

الكنية العاني

 

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

أخي الكريم محي الدين ..

يمكنك التغلب على هذه المشكلة بأن تحذف المسافة في الاسم المركب حيث أنه يستحيل التعامل مع كل الأسماء المركبة .. لأن هناك أسماء فيها اسم محمد وسعيد وغير مركبة ..كيف سيتعرف الإكسيل عليها في هذه الحالة ؟؟ ما هو المنطق الذي سيتم تتبعه لحل مشكلة الأسماء المركبة في هذه الحالة

وأنا أخبرت أن الدالة تعمل بنسبة كبيرة ولكن لن تصل إلى نسبة 100% .. فيمكن التغلب ببساطة على هذه المشكلة بأن لا تضع مسافة بين الأسماء المركبة فيكون الاسم محمدسعيد بشكل مباشر بدون مسافة بينهما

هذا والله أعلم

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

استاذي العزيز

كلامك صح 100%

وآسف اذا كنت أزعجتك

ولكن ما حصل معي انه أتاني قائمة اسماء من مصدر وقائمة لنفس الأسماء من مصدر آخر ( حوالي 9000 اسم) والمطلوب مني ان أنقل معلمة من احدى القائمتين للقائمة الثانية

المشكلة ان من كتب الاسماء شخصين مختلفين وهناك مشاكل كثيرة بين القائمتين واضناني الموضوع والآب بقي حوالي 2500 اسم لم اصل لنقل المعلومة من احدى القائميتن للثانية 

هذه مشكلتي واسف مرة اخرى على ازعاجك وسامحني

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

4 ساعات مضت, محي الدين ابو البشر said:

استاذي العزيز

كلامك صح 100%

وآسف اذا كنت أزعجتك

ولكن ما حصل معي انه أتاني قائمة اسماء من مصدر وقائمة لنفس الأسماء من مصدر آخر ( حوالي 9000 اسم) والمطلوب مني ان أنقل معلمة من احدى القائمتين للقائمة الثانية

المشكلة ان من كتب الاسماء شخصين مختلفين وهناك مشاكل كثيرة بين القائمتين واضناني الموضوع والآب بقي حوالي 2500 اسم لم اصل لنقل المعلومة من احدى القائميتن للثانية 

هذه مشكلتي واسف مرة اخرى على ازعاجك وسامحني

حاول تطرح المشكلة ليشاركك الأخوة الأعضاء في محاولة حلها .. إن شاء الله تكون مشكلة بسيطة لو حاولنا فيها كلنا ..غير لما تحاول لوحدك

أخي الحبيب مختار البركاني

مشكور على مرورك العطر بالموضوع .. ونورت الموضوع .. ولعلك استفدت

تقبلوا تحياتي

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

استاذنا العزيز ياسر خليل أبو البراء  بارك الله فيك وزادك الله علما

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

فهلا تكرمت مشكورا  التوضيح اين كان الخطاء  عندي

ومرفق  الملف الذي اعمل عليه واريد في ورقتين نفس الكود  وستلاحظ انني عملت في هذه الورقتين مربعين باسم (تحديث بيانات الطالب)   و(تحديث بيانات الام )

كشوفات خاصه لتعبئة الشهائد.rar

تم تعديل بواسطه عبدالعزيزالمدني
رابط هذا التعليق
شارك

أخي الكريم عبد العزيز المدني

الملف محفوظ بصيغة xlsx وهذا الامتداد لا يحتفظ بالأكواد ..عندما تضع الكود وتحفظ ستظهر رسالة فيها كلمة Yes و No و Cancel انقر No سيظهر معك مربع حواري تحدد من خلاله اسم الملف والمكان المطلوب حفظ المصنف فيه وأهم شيء هو امتداد الملف اختار xlsm أو Excel Macro Enabled

يمكنك الإطلاع على الموضوع التالي لتدرك بدايات التعامل مع الأكواد

http://بداية الطريق لإنقاذ الغريق

 

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

استاذنا العزيز ياسر خليل أبو البراء  للاسف لم استطع تنفيذ الماكرو كما يجب

ارجوا مساعدتي شاكرا تعاونك  ولا املك الا ان اقول سهل الله امرك ويسر دربك وادخلك الجنة انه سميع مجيب

كشوفات خاصه لتعبئة الشهائد.rar

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

أخي الكريم عبد العزيز المدني

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

Sub TestRun()
    Dim I As Long
    For I = 8 To Cells(Rows.Count, "B").End(xlUp).Row
        If Kh_Names(Cells(I, "B"), 1) = Cells(I, "B") Then
            Cells(I, "E") = Kh_Names(Cells(I, "B"), 1)
        ElseIf Kh_Names(Cells(I, "B"), 1, 2) = Cells(I, "B") Then
            Cells(I, "E") = Kh_Names(Cells(I, "B"), 1)
            Cells(I, "I") = Kh_Names(Cells(I, "B"), 2)
        ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3) = Cells(I, "B") Then
            Cells(I, "E") = Kh_Names(Cells(I, "B"), 1)
            Cells(I, "F") = Kh_Names(Cells(I, "B"), 2)
            Cells(I, "I") = Kh_Names(Cells(I, "B"), 3)
        ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3, 4) = Cells(I, "B") Then
            Cells(I, "E") = Kh_Names(Cells(I, "B"), 1)
            Cells(I, "F") = Kh_Names(Cells(I, "B"), 2)
            Cells(I, "G") = Kh_Names(Cells(I, "B"), 3)
            Cells(I, "I") = Kh_Names(Cells(I, "B"), 4)
        ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3, 4, 5) = Cells(I, "B") Then
            Cells(I, "E") = Kh_Names(Cells(I, "B"), 1)
            Cells(I, "F") = Kh_Names(Cells(I, "B"), 2)
            Cells(I, "G") = Kh_Names(Cells(I, "B"), 3)
            Cells(I, "H") = Kh_Names(Cells(I, "B"), 4)
            Cells(I, "I") = Kh_Names(Cells(I, "B"), 5)
        Else
            Cells(I, "E") = Kh_Names(Cells(I, "B"), 1)
            Cells(I, "F") = Kh_Names(Cells(I, "B"), 2)
            Cells(I, "G") = Kh_Names(Cells(I, "B"), 3)
            Cells(I, "H") = Kh_Names(Cells(I, "B"), 4)
            Cells(I, "I") = Kh_Names(Cells(I, "B"), 5)
        End If
    Next I
End Sub

Function Kh_Names(FullName As String, ParamArray Index1()) As String
    Dim I As Integer
    Dim Kh_Split, MyArray, Arr
    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 Arr In MyArray
        RE = Replace(Arr, " ", "^")
        SN = Replace(SN, Arr, 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

بالنسبة لنتائج الكود لن تكون صحيحة بسبب سوء البيانات المدخلة

فمثلا الاسم

ناصرسعدناصرمحمدالغيلي

لا توجد أية مسافات في الاسم من ثم سيعامله الكود على أنه اسم واحد ويتم وضع كامل الاسم في خلية الاسم فقط

 

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

إذا أردت أن تحصل على نتائج صحيحة فلابد أن تكون المدخلات صحيحة

تقبل تحياتي

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

تسلم استاذ ياسر خليل أبو البراء  وجزاك الله الف خير

لو تكرمت تابع تعديل الملف المرفق  وعدل كود تحديث بيانات الام فلم استطع اصلاحه كما الكود الاول اسم الطالب

كشوفات خاصه لتعبئة الشهائد.rar

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

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

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

Important Information