ارجو المساعدة فك اسم رباعي الى 4 اسماء في 4 خلايا مختلفة

[اشرف النعاس]

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

New Microsoft Excel Worksheet (4).rar

[أبو حنــــين]

جرب المرفق

 

 

New Microsoft Excel Worksheet (6).rar

تم تعديل يونيو 25, 2016 بواسطه أبو حنــــين

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

بارك الله فيك أخي الحبيب أبو حنين وجزيت خيراً على هذه الحلول المتميزة

إثراءً للحل وللموضوع أقدم حل آخر

ضع الكود التالي في موديول عادي (دالة معرفة)

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

    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 I
    On Error GoTo 0

    Kh_String = Replace(Trim(Kh_String), "^", " ")
    Kh_Names = Kh_String

    Exit Function

Err_Kh_Names:
    Kh_Names = ""
End Function

ثم ضع الكود التالي في حدث الفورم

Private Sub CommandButton1_Click()
    Dim Sh As Worksheet, Last As Long
    
    If Me.TextBox1 = "" Then Exit Sub
    Set Sh = Sheets("Sheet1")

    With Sh
        Last = .Cells(Rows.Count, 10).End(xlUp).Row + 1

        .Cells(Last, "G") = Kh_Names(Me.TextBox1.Text, 1)
        .Cells(Last, "H") = Kh_Names(Me.TextBox1.Text, 2)
        .Cells(Last, "I") = Kh_Names(Me.TextBox1.Text, 3)
        .Cells(Last, "J") = Kh_Names(Me.TextBox1.Text, 4)
    End With
End Sub

تقبل تحياتي