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

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

أخي الحبيب عبد العزيز المدني

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

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

والتعديل الثاني هو رقم العمود الموجود فيه الأسماء ..اكتب رقم العمود فإذا كان العمود هو العمود J ستكتب 10

 

أرجو أن يكون التعديل مناسب لك

Sub PopulateFullNamesToAdjacentColumns()
    Dim I As Long, strName As String
    
    'Row Number Where Names Start
    Const Row As Long = 2
    
    'Column Number Where Names Exist >> 1 For A - 2 For B - 3 For C ...
    Const Col As Long = 2
    
    For I = Row To Cells(Rows.Count, Col).End(xlUp).Row
        strName = Cells(I, Col).Value
        
        If Kh_Names(strName, 1) = strName Then
            Cells(I, Col + 1) = Kh_Names(strName, 1)
        ElseIf Kh_Names(strName, 1, 2) = strName Then
            Cells(I, Col + 1) = Kh_Names(strName, 1)
            Cells(I, Col + 5) = Kh_Names(strName, 2)
        ElseIf Kh_Names(strName, 1, 2, 3) = strName Then
            Cells(I, Col + 1) = Kh_Names(strName, 1)
            Cells(I, Col + 2) = Kh_Names(strName, 2)
            Cells(I, Col + 5) = Kh_Names(strName, 3)
        ElseIf Kh_Names(strName, 1, 2, 3, 4) = strName Then
            Cells(I, Col + 1) = Kh_Names(strName, 1)
            Cells(I, Col + 2) = Kh_Names(strName, 2)
            Cells(I, Col + 3) = Kh_Names(strName, 3)
            Cells(I, Col + 5) = Kh_Names(strName, 4)
        ElseIf Kh_Names(strName, 1, 2, 3, 4, 5) = strName Then
            Cells(I, Col + 1) = Kh_Names(strName, 1)
            Cells(I, Col + 2) = Kh_Names(strName, 2)
            Cells(I, Col + 3) = Kh_Names(strName, 3)
            Cells(I, Col + 4) = Kh_Names(strName, 4)
            Cells(I, Col + 5) = Kh_Names(strName, 5)
        Else
            Cells(I, Col + 1) = Kh_Names(strName, 1)
            Cells(I, Col + 2) = Kh_Names(strName, 2)
            Cells(I, Col + 3) = Kh_Names(strName, 3)
            Cells(I, Col + 4) = Kh_Names(strName, 4)
            Cells(I, Col + 5) = Kh_Names(strName, 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

تقبل تحياتي

 

Populate Full Names To Adjacent Columns YasserKhalil.rar

[مهند الزيدي]

شكر خاص للأخ ياسر خليل المبدع ... وفقه الله لكل خير .. دائما ما تجد الحلول المميزة في جعبته ..

أخي العزيز ياسر ممكن إذا أردنا أن تكون إدخال إسم ثنائي وتكون النتيجة أول حرف من الإسم الأول والإسم الثاني مثلاً

ياسر خليل   -  ي.خليل

ياسر العربي - ي.العربي

مهند الزيدي - م.الزيدي

مساعد محاسب - م.محاسب

 

تم تعديل يناير 20, 2016 بواسطه مهند الزيدي

[أبوبسمله]

جزاك الله كل خير يا أبو البراء

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

12 ساعات مضت, مهند الزيدي said:

شكر خاص للأخ ياسر خليل المبدع ... وفقه الله لكل خير .. دائما ما تجد الحلول المميزة في جعبته ..

أخي العزيز ياسر ممكن إذا أردنا أن تكون إدخال إسم ثنائي وتكون النتيجة أول حرف من الإسم الأول والإسم الثاني مثلاً

ياسر خليل   -  ي.خليل

ياسر العربي - ي.العربي

مهند الزيدي - م.الزيدي

مساعد محاسب - م.محاسب

 

أخي الكريم مهند

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

تقبل تحياتي

[مهند الزيدي]

شكرا جزيلا لك أخي ياسر وفقكم الله لكل خير