فرز اسماء

[الشيباني1]

اخواني الاعزاء  تحية طيبه  ارجو المساعده في فرز اسماء تضمنها الملف المرفق  مع التقدير

فرز اسماء.rar

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

أخي الكريم الشيباني

جرب الكود التالي عله يفي بالغرض إن شاء الله

Sub Test()
    Dim Lr As Long, I As Long
    
    On Error Resume Next
        ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\System32\vbscript.dll\3"
    On Error GoTo 0
    
    With ActiveSheet
        Lr = .Cells(.Rows.Count, "G").End(xlUp).Row
        
        For I = 4 To Lr
            .Range("H" & I).Resize(1, 3).Value = English_Arabic_Numbers(.Range("G" & I).Value)
        Next I
    End With
End Sub

Private Function English_Arabic_Numbers(ByVal Nms As String)
    Dim E$, A$, Nm$
    Dim V_r As Object
    
    Set V_r = CreateObject("VBScript.Regexp")
    On Error Resume Next
    
    With V_r
        .Global = True
        .IgnoreCase = True
        .Pattern = "\w|\n|\-|\(|\)|\&|\."
        A = Trim(.Replace(Nms, ""))
        .Pattern = "\D+"
        E = Trim(.Replace(Nms, ""))
        .Pattern = "[-?\d+(\.\d+)?|\u0600-\u06FF]"
        Nm = Trim(.Replace(Nms, ""))
    End With
    
    English_Arabic_Numbers = Array(Nm, A, E)
    Set V_r = Nothing
End Function

تقبل تحياتي

[الشيباني1]

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

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

افتح ملفك

اضغط Alt + F11 للدخول لمحرر الأكواد

من قائمة Insert اختر Module لإدراج موديول جديد

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

الصقه في الموديول الجديد الذي تم إدراجه

اذهب لورقة العمل واضغط Alt + F8 من لوحة المفاتيح واختر الإجراء الفرعي المسمى Test ثم انقر Run

 

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

للمزيد يرجى زيارة الرابط التالي

من هنا

[الشيباني1]

استاذنا القدير  اعتذر جدا عن هذا الالتباس الذي كان سببه اخفائي الاعمده التي تم فيها الفرز واشكرك على هذا الابداع واتساءل عن امكانية اجراء تعديل ليكون المفرز في الاعمده ( M N O ) كما اوضحتها في المرفق وامكانية الحل بالمعادلات  مع تقديري

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

للحصول على النتائج في الأعمدة المطلوبة قم فقط بتغيير الحرف H إلى M في السطر التالي في الكود

.Range("H" & I).Resize(1, 3).Value = English_Arabic_Numbers(.Range("G" & I).Value)

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

 

[الشيباني1]

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

[عبدالسلام ابوالعوافي]

وايضا

Sub Awafi()
    Dim i As Integer, ii As Integer, iii As Integer
    Dim s1 As String, s2 As String, s3 As String, s As String
    
    For i = 4 To 1000
        s1 = "": s2 = "": s3 = ""
        If Cells(i, "g") = "" Then Exit For
        iii = Len(Cells(i, "g"))
        For ii = 1 To iii
            s = Mid(Cells(i, "g"), ii, 1)
            If s = " " Then s1 = s1 & s: s2 = s2 & s: s3 = s3 & s
            If s < "A" Then
            s3 = s3 & s
            ElseIf s > "z" Then
            s2 = s2 & s
            Else
            s1 = s1 & s
            End If
        Next ii
        Cells(i, "m") = Trim(s1)
        Cells(i, "n") = Trim(s2)
        Cells(i, "o") = Trim(s3)
    Next i
End Sub

 

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

كود ممتاز وبسيط ورائع أخي الغالي عبد السلام

بارك الله فيك وجزيت خيراً

[الشيباني1]

اخي العزيز ابو العوافي  كود رائع بوركت ودمت لنا مرجعا