الشيباني1 قام بنشر أغسطس 14, 2016 مشاركة قام بنشر أغسطس 14, 2016 اخواني الاعزاء تحية طيبه ارجو المساعده في فرز اسماء تضمنها الملف المرفق مع التقدير فرز اسماء.rar رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر أغسطس 14, 2016 مشاركة قام بنشر أغسطس 14, 2016 أخي الكريم الشيباني جرب الكود التالي عله يفي بالغرض إن شاء الله 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 رابط هذا التعليق شارك More sharing options...
الشيباني1 قام بنشر أغسطس 14, 2016 الكاتب مشاركة قام بنشر أغسطس 14, 2016 استاذنا القدير مع شكري وتقديري لم يعمل الكود بالشكل المطلوب ارجو المساعده بادخال الكود ضمن المرفق وتفعيله مع الامتنان رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر أغسطس 14, 2016 مشاركة قام بنشر أغسطس 14, 2016 افتح ملفك اضغط Alt + F11 للدخول لمحرر الأكواد من قائمة Insert اختر Module لإدراج موديول جديد انسخ الكود الموضوع في مشاركتي السابقة الصقه في الموديول الجديد الذي تم إدراجه اذهب لورقة العمل واضغط Alt + F8 من لوحة المفاتيح واختر الإجراء الفرعي المسمى Test ثم انقر Run لابد أن تتعلم الأساسيات في التعامل مع محرر الأكواد للمزيد يرجى زيارة الرابط التالي من هنا رابط هذا التعليق شارك More sharing options...
الشيباني1 قام بنشر أغسطس 14, 2016 الكاتب مشاركة قام بنشر أغسطس 14, 2016 استاذنا القدير اعتذر جدا عن هذا الالتباس الذي كان سببه اخفائي الاعمده التي تم فيها الفرز واشكرك على هذا الابداع واتساءل عن امكانية اجراء تعديل ليكون المفرز في الاعمده ( M N O ) كما اوضحتها في المرفق وامكانية الحل بالمعادلات مع تقديري رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر أغسطس 14, 2016 مشاركة قام بنشر أغسطس 14, 2016 للحصول على النتائج في الأعمدة المطلوبة قم فقط بتغيير الحرف H إلى M في السطر التالي في الكود .Range("H" & I).Resize(1, 3).Value = English_Arabic_Numbers(.Range("G" & I).Value) بالنسبة للحل بالمعادلات فليس لي علم بها .. وسأترك الأمر للأخوة المتمكنين في المعادلات وإن شاء الله يصلوا لحل يناسبك رابط هذا التعليق شارك More sharing options...
الشيباني1 قام بنشر أغسطس 14, 2016 الكاتب مشاركة قام بنشر أغسطس 14, 2016 اشكرك جدا استاذنا القدير وادامك الرحمن لنا مرجعا رابط هذا التعليق شارك More sharing options...
عبدالسلام ابوالعوافي قام بنشر أغسطس 14, 2016 مشاركة قام بنشر أغسطس 14, 2016 وايضا 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 رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر أغسطس 15, 2016 مشاركة قام بنشر أغسطس 15, 2016 كود ممتاز وبسيط ورائع أخي الغالي عبد السلام بارك الله فيك وجزيت خيراً 1 رابط هذا التعليق شارك More sharing options...
الشيباني1 قام بنشر أغسطس 15, 2016 الكاتب مشاركة قام بنشر أغسطس 15, 2016 اخي العزيز ابو العوافي كود رائع بوركت ودمت لنا مرجعا رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان