اذهب الي المحتوي
بحث مخصص من جوجل فى أوفيسنا
Custom Search
أ / محمد صالح

أسهل دالة معرفة لجلب التفقيط الموافق لقواعد اللغة العربية من الموقع

Recommended Posts

بسم الله الرحمن الرحيم

كيف الحال أحبابي في الله

إن شاء الله بخير وسعادة ورضا

كل عام أنتم جميعا بخير

نلتقي من جديد في شهر ميلاد سيد الخلق

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

**********

بناء على طلب الأخ الفاضل @عبدالرحمن وسلمى

قمت بعمل دالة معرفة لجلب ناتج التفقيط الموجود في الموقع الشخصي لي

https://a1mas.com/التفقيط-تحويل-الأرقام-لكلمات-عربية/

إلى ملف إكسل أو أكسس

بشرط الاتصال بالانترنت

==============

الجميل في الصفحة أنها تراعي بإذن الله

كل قواعد صياغة العدد في اللغة العربية

ولا تحتوي على أخطاء إملائية ولا نحوية

وتمت برمجتها بلغة php لأني لم أجد من المرونة في لغة فيجوال بيسك للتطبيقات vba ما يسمح بنفس البرمجة المستخدمة في لغة الويب php

لذا تم التحايل على الأمر بكود

يقوم بطلب الصفحة الخاصة بالتفقيط وتمرير البيانات الخاصة بنا من صفحة الإكسل إلى الموقع

ثم يسجل ما يعود به الموقع في الخلية

============

ويمكن الاستفادة من الكود في جلب بيانات أي صفحة من الانترنت عن طريقة vba

والآن أترككم مع الملف

 

التفقيط من الانترنت.rar

  • Like 1
  • Thanks 1

شارك هذه المشاركه


رابط المشاركه
شارك

جزاك الله خير الجزاء

 

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

 

Function n2t(d As Double) As String
m = Int(d / 100)
h = Int(d / 10) - (m * 10)
a = Int(d - (m * 100 + h * 10))
k = d - (m * 100 + h * 10 + a)
n2t = num((m), 3) & IIf(m > 0 And (a > 0 Or h > 0), " و ", "") & num((a), 1) & IIf(a > 0 And h > 1, " و ", " ") & num((h), 2)
n2t = Replace(n2t, "اثنتانِ عشرة", "اثنتا عشرة")
n2t = Replace(n2t, "ثمانمائة", "ثمنمائة")
n2t = Replace(n2t, "ثلاثمائة", "ثلثمائة")
n2t = Replace(n2t, "و  عشرة", "و عشر")
n2t = IIf(n2t = " عشرة", "عشر", n2t)
n2t = IIf(n2t = "مائتانِ ", "مائتا", n2t)
n2t = "فقط " & n2t & IIf(h = 0 And a = 2, "درجتانِ", IIf((h = 1 And a = 0) Or ((h = 0 And a > 2)), " درجاتٍ", IIf(h = 0 And a = 0, " درجةٍ", " درجةً"))) & IIf(k > 0, " و نصفٌ", "")
n2t = Replace(n2t, "  ", " ")
n2t = Replace(n2t, "إحدى درجةً", "درجةٌ")
n2t = Replace(n2t, "اثنتانِ درجتانِ", "درجتانِ")
End Function
Function num(n As Integer, t As Integer) As String
m = "مائة"
h = "ونَ"
Select Case n
Case Is = 1
num = IIf(t = 3, m, IIf(t = 2, "عشرة", "إحدى"))
Case Is = 2
num = IIf(t = 3, "مائتانِ", IIf(t = 2, "عشرونَ", "اثنتانِ"))
Case Is >= 3
num = IIf(t = 3, nn(n) & m, IIf(t = 2, nn(n) & h, nn(n)))
End Select
End Function
Function nn(n As Integer) As String
Select Case n
Case Is = 3
nn = "ثلاث"
Case Is = 4
nn = "أربع"
Case Is = 5
nn = "خمس"
Case Is = 6
nn = "ست"
Case Is = 7
nn = "سبع"
Case Is = 8
nn = "ثمان"
Case Is = 9
nn = "تسع"
End Select
End Function

 

شارك هذه المشاركه


رابط المشاركه
شارك

شكرا لتواصلك أخي الكريم

إن شاء الله سيتم فتح موضوع جديد بهذا الخصوص

ولكن لم تخبرنا برأيك في الموضوع المنشور

:rol:

  • Like 1

شارك هذه المشاركه


رابط المشاركه
شارك

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

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

خاصة وأن التفقيط كان بالحركات المناسبة مثلا يقرأ العدد 33  ثلاثٌ وثلاثونَ درجةٌ 

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

شارك هذه المشاركه


رابط المشاركه
شارك

لا حرمك الله الاجر وجعله في ميزان حسناتك  استاذ محمد صالح

 
'صمم بواسطة أ / محمد صالح 10/2/2011
'تم التعديل لإضافة الصفر والنصف 28/4/2015
'تم التعديل للوصول إلى 9999 والسماح بكتابة غ للغياب في 27/11/2017
' https://a1mas.com
Function n2t(d As String) As String
If d = "" Or d = "غ" Then
n2t = "غ"
ElseIf d = 0 Or d > 9999.5 Then
n2t = "لا شيء"
ElseIf d = 0.5 Then
n2t = "فقط نصف درجة"
Else
o = Int(d / 1000)
m = Int(d / 100) - (o * 10)
h = Int(d / 10) - (o * 100 + m * 10)
a = Int(d - (o * 1000 + m * 100 + h * 10))
k = d - (o * 1000 + m * 100 + h * 10 + a)
n2t = num((o), 4) & IIf(o > 0 And (a > 0 Or h > 0 Or m > 0), " و", "") & num((m), 3) & IIf(m > 0 And (a > 0 Or h > 0), " و", "") & num((a), 1) & IIf(a > 0 And h > 1, " و", " ") & num((h), 2)
n2t = Replace(n2t, "و ", "و")
n2t = Replace(n2t, "اثنتانِ عشرة", "اثنتا عشرة")
n2t = Replace(n2t, "وعشرة", "وعشر")
n2t = IIf(n2t = " عشرة", "عشر", n2t)
n2t = IIf(n2t = "مائتانِ ", "مائتا", n2t)
n2t = IIf(n2t = "ألفان ", "ألفا", n2t)
n2t = "فقط " & n2t & IIf(h = 0 And a = 2, "درجتانِ", IIf((h = 1 And a = 0) Or ((h = 0 And a > 2)), " درجاتٍ", IIf(h = 0 And a = 0, " درجةٍ", " درجةً"))) & IIf(k > 0, " ونصفٌ", "")
n2t = Replace(n2t, "إحدى  درجةً", "درجةٌ")
n2t = Replace(n2t, "اثنتانِ درجتانِ", "درجتانِ")
n2t = Replace(n2t, "مائتانِ  درجةٍ", "مائتا درجةٍ")
End If
n2t = Trim(n2t)
End Function
Function num(n As Integer, t As Integer) As String
o = "ة آلاف"
m = "مائة"
h = "ونَ"
Select Case n
Case Is = 1
num = IIf(t = 4, "ألف", IIf(t = 3, m, IIf(t = 2, "عشرة", "إحدى")))
Case Is = 2
num = IIf(t = 4, "ألفان", IIf(t = 3, "مائتانِ", IIf(t = 2, "عشرونَ", "اثنتانِ")))
Case Is >= 3
num = IIf(t = 4, nn(n) & o, IIf(t = 3, nn(n) & m, IIf(t = 2, nn(n) & h, nn(n))))
End Select
End Function
Function nn(n As Integer) As String
Select Case n
Case Is = 3
nn = "ثلاث"
Case Is = 4
nn = "أربع"
Case Is = 5
nn = "خمس"
Case Is = 6
nn = "ست"
Case Is = 7
nn = "سبع"
Case Is = 8
nn = "ثمان"
Case Is = 9
nn = "تسع"
End Select
End Function

الكود بعد التعديل للمحترم محمد صالح

رزقه الله الرزق الواسع ونحن معه 

وان يصلح الله حاله وحالنا ..

=====

=n2t(A1)

هذه الجمله هي التي تكتب في صفحه ااكسيل وتكتب الارقام في الخليه A1  على سبيل  المثال

اخي الكريم

انه يقرب الارقام بطريقه غير مفهومه

 

11.png

شارك هذه المشاركه


رابط المشاركه
شارك

المطلوب من الكود هو تفقيط الدرجة والنصف فقط

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

خمس وعشرون درجة و عشر أحزاء

على أساس أن المعدود درجة والكسر جزء

........................

هذه حكاية هذا الكود أنه لا يوجد اسم للكسر

وإنما كان المطلوب أي كسر يتم تحويله لنصف

 

  • Like 1

شارك هذه المشاركه


رابط المشاركه
شارك

بسم الله الرحمن الرحيم

وبه نستعين

اخى وحبيبى فى الله ابو صالح

السلام عليكم ورحمته الله وبركاته

اود فى البداية وقبل تحميل المرفق ان تتقبل اعتذراى الشديد

لعدم الرد فى حينة لظروف خارجة عن إرادتى

ثانيا اشكرك من صميم قلبى على هذة اللفتة الطيبة المباركة

النى احتسبها ان شاء الله تعالى فى موازيين حسناتك يوم القيامة

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

بعد تجربة المرفق على الملف الاصلى الذى أرغب العمل عليه على اعتبار ان التجربة جديدة من نوعها

وفقنا الله واياكم الى مايحبة ويرضاه

تقبل وافر تقديرى واحترامى وجزاكم الله خيرا

شارك هذه المشاركه


رابط المشاركه
شارك

شكرا لمروركم الكريم

وفقنا الله جميعا لكل خير

شارك هذه المشاركه


رابط المشاركه
شارك

انشئ حساب جديد او قم بتسجيل دخولك لتتمكن من اضافه تعليق جديد

يجب ان تكون عضوا لدينا لتتمكن من التعليق

انشئ حساب جديد

سجل حسابك الجديد لدينا في الموقع بمنتهي السهوله .

سجل حساب جديد

تسجيل دخول

هل تمتلك حساب بالفعل ؟ سجل دخولك من هنا.

سجل دخولك الان


  • محتوي مشابه

    • بواسطه أ / محمد صالح
      بسم الله الرحمن الرحيـــــم
      السلام عليكم ورحمة الله وبركاته
      حياكم الله جميعاً إخوتي وأحبابي في الله أعضاء بيتنا الثاني أوفيسنا
      هل أردت الاستمتاع بمجموعة من الوسائط (ملفات صوتية أو فيديوهات) من مجموعة من المجلدات؟؟
      وتعذبت في فتح ملف ثم غلق مشغل الوسائط ( الميديا بلاير ) والتوجه لفتح الآخر وهكذا إلى آخر المجموعة؟؟
      هل تعبت من البحث عن الملفات ذات امتداد معين من بين ملفات مجموعة من المجلدات ووضعها في مجلد مستقل كي تسمعها أو تشاهدها منظمة؟؟
      هل .....؟
      هل ......؟
      اليوم أقدم لكم هدية بسيطة جداً لعمل كل ما سبق
      فكرة الهدية:
      عمل ملف فيجوال بيسك سكريبت vbs يقوم بقراءة الملفات الموجودة في المجلد الذي يتم تمريره للكود وكذلك الملفات الموجودة في المجلدات الفرعية ضمن المجلد الأصلي ووضع ما يتفق مع مجموعة الامتدادات المسموحة منك جميعاً في قائمة تشغيل بامتداد m3u والتي تعمل على كل مشغلات الميديا.
      نأتي الآن للطريقة:
      افتح أي محرر نصوص مثل نوت باد وانسخ هذا الكود والصقه فيه
        On Error Resume Next Dim Exts, LstPath, Folder, NewFile, ObjFile, Ext Exts = split("mov,mp3,flv" , ",") Set Folder = CreateObject("Scripting.FileSystemObject").GetFolder(Wscript.Arguments.Item(0)) LstPath = Folder.ParentFolder.path & "\" & Folder.name & ".m3u" Set NewFile = CreateObject("Scripting.FileSystemObject").CreateTExtFile(LstPath, 1) add2lst(Folder.Files) For Each SubFolder in Folder.SubFolders add2lst(SubFolder.Files) Next NewFile.Close CreateObject("WScript.Shell").Run """" & LstPath & """" Function add2lst(files) For each ObjFile In files For each Ext In Exts if right(ObjFile.Name, 3) = Ext then NewFile.WriteLine(ObjFile.path) Next Next End Function ثم احفظ هذا الملف باسم MakePlayList.vbs أو أي اسم آخر ولكن لاحظ الامتداد ليس txt وإنما vbs وحاول أن تضع الملف أثناء عملية الحفظ في أحد محركات القرص الصلب مباشرة يعني مثلا D:\MakePlayList.vbs لا تجرب الملف الآن فلن يعمل يلزمنا الآن أن نضيف في القائمة المختصرة للمجلدات الأمر الخاص باستدعاء تنفيذ الكود الموجود في ملف vbs مع إعطائه مسار المجلد الذي تم ضغط زر الفارة الأيمن عليه وذلك عن طريق ما يلي: افتح برنامج النوت باد أو اي محرر نصوص تريده انسخ الكود التالي والصقه فيه
        Windows Registry Editor Version 5.00 [HKEY_CLASSES_ROOT\Folder\shell\Make Playlist\command] @="wscript G:\\MakePlayList.vbs \"%1\"" قم بحفظ الملف بأي اسم تريده مع التأكيد على أن الامتدادا reg وليكن مثلا MakePlayList.reg لاحظ في السطر الثالث من كود ملف الريجيستري هو مسار الملف vbs الذي أنشأناه سابقا ووضعناه في القرص الصلب D ولكن في الكود استعملت القرص الصلب G للتأكيد على إمكانية تغيير مسار الملف ولكن مع ضرورة كتابة مساره في ملف الريجيستري بصورة دقيقة. طب هنا هيسأل واحد ليه نحط ملف vbs في القرص الصلب مباشرة؟؟!! يعني ليه منحطوش في أي مكان تاني؟؟ الإجابة: لو تعرف تكتب المسار بتاع ملف vbs كامل ومظبوط مع مراعاة أن الشرطة الخلفية \ تكتب شرطتين \\ مفيش مشكلة (حطه في أي مكان يعجبك) مع مراعاة كتابة مساره بصورة صحيحة تبقى لنا أن نضغط على ملف الريجيستري مرتين لتشغيله ثم نعم ثم موافق كده كل حاجة جاهزة جرب كده بقة يا عم الحاج تروح لمجلد فيه فيديوهات أو ملفات صوت وتعمل عليه كلك يمين وتختار Make Playlist هتلاقي إنه تم إنشاء ملف بجوار المجلد يمكنك تشغيل كل الملفات التي بداخل المجلد من خلاله في صورة قائمة تشغيل نأتي الآن لجزئية مهمة جداً وهي التعديل على ملف vbs ليتناسب مع احتياجاتك إذا أردت مثلا وضع ملفات mp3 فقط من ضمن المجلد يمكنك تعديل السطر الثالث الخاص بالامتدادات
        Exts = split("mov,flv,mp3,wav" , ",") هنا في الكود أنا وضعت أكثر من امتداد لكي أوضح طريقة كتابة أكثر من امتداد على شكل المصفوفة وذلك بكتابة الامتداد ثم فاصلة ثم الذي يليه وهكذا وإذا كان الامتداد واحد فقط يجب أن يكون بنفس الصورة مع حذف الفواصل
        Exts = split("mov" , ",") ومرفق الملفين ولكن يفضل أن تجرب أن تقوم بها وحدك
      وهذه طريقة أخرى لعمل نفس المطلوب ولكن من خلال الدوس DOS باستعمال ملف batch بالفيديو
       
       
       
      وفي الأخير
      أتمنى أن أكون وفقت في إيصال المعلومة المفيدة للكثير منا
      وأتمنى أن تكون الهدية البسيطة نالت إعجابكم
      ولا تنسوني من صالح دعائكم
      حتى يقول لك الملك آمين ولك مثلها
      ويرجى مشاركة الموضوع حتى تعم الفائدة
       
      MakePlayList.rar
    • بواسطه أ / محمد صالح
      بسم الله الرحمن الرحيم، السلام عليكم ورحمة الله وبركاته، أسعد الله أوقاتكم من جديد موعدنا اليوم مع معلومة مفيدة جدا ومتقدمة جدا، ومهمة جدا في نفس الوقت، ألا وهي شرح عرض جميع الملفات والمجلدات في مسار list all files and folders in path في vba فتابعونا.
      شرح عرض جميع الملفات والمجلدات في مسار list all files and folders in path في vba
      طلب مني أحد الأصدقاء الإجابة عن استفسار بخصوص البحث عن مجموعة من الملفات في مسار معين ثم نسخ هذه الملفات إلى مجلد جديد.
      فقررت عمل شرح عرض جميع الملفات والمجلدات في مسار list all files and folders in path في vba
      باستخدام دالة معرفة UDF وإجراء يمكن استعماله في كل تطبيقات أوفيس
      تابعونا
         
      للإجابة عن هذا السؤال وأكثر تابعونا في هذا الفيديو
      ونتعرف أيضا على:
      إنشاء إنشاء إجراء sub في إكسل
      إجراء لعرض جميع الملفات الموجودة في مسار معين
      وكذلك عرض جميع المجلدات الفرعية داخل المسار
      عرض ملفات معينة بامتداد معين في مسار
      معرفة حجم مجلد بالبايت والميجايت
      استخدام صندوق حواري لتحديد مجلد folder picker
      تجاوز الخطأ إذا لم يقم المستخدم بتحديد مجلد
      برمجة دالة بوسائط اختيارية يمكن عدم كتابتها مع إعطائها قيمة افتراضية
        الكتابة في الخلية المجاورة لنطاق باستعمال الدالة offset
      البحث عن مجموعة من الملفات مكتوبة في نطاق من الخلايا
      استدعاء إجراء من داخل إجراء آخر أو من داخل نفسه
      والكثير من المهارات الأساسية في فيجوال بيسك للتطبيقات وفي معادلات إكسل
      لا أريد أن أطيل عليكم تابعوا معي هذا الفيديو شرح عرض جميع الملفات والمجلدات في مسار list all files and folders in path في vba الشرح يعمل في إكسل 2016 و 2013 و 2010 و 2007

      رابط الملف المستعمل في الشرح
      اضغط هنا للوصول للملف
      للمزيد زوروا ميكروسوفت إكسل Microsoft excel
      ولا ينقصني سوى دعاؤكم لي ولأهلي وأحبابي -وأنتم منهم- بخيري الدنيا والآخرة.
      ومشاركة الموضوع مع من يهمه الأمر
      لو بخل بها غيرك ما وصلت إليك
      ولا تنس تقييم المنشور
      list all files and folders in path.rar
    • بواسطه أ / محمد صالح
      بسم الله الرحمن الرحيم، السلام عليكم ورحمة الله وبركاته، أسعد الله أوقاتكم من جديد موعدنا اليوم مع معلومة مفيدة جدا ومتقدمة جدا، ومهمة جدا في نفس الوقت، ألا وهي تدوير وانعكاس الجداول في إكسل flip rotate transpose tables in excel فتابعونا.
      تدوير وانعكاس الجداول في إكسل flip rotate transpose tables in excel
      ربما تعرضت لنسخ جدول من برنامج ميكروسوفت وورد إلى إكسل، ولكن وجدت أن اتجاه الجدول من اليسار لليمين، قمت بعدة محاولات وتغيير اتجاه الشيت في إكسل ولكن لم تحصل على النتيجة المطلوبة، وتريد عكس اتجاه الجدول أفقيا Flip horizontal
      أو عكس اتجاه الجدول رأسيا Flip vertical أو حتى عكس اتجاه الجدول بزاوية Flip diagonal .
      أو تريد تدوير الجدول لليسار Rotate left أو تدوير الجدول لليمين Rotate right أو تريد تبديل الصفوف إلى أعمدة Transpose
      فقررت تصميم دالة معرفة تقوم بالمطلوب وكذلك مجموعة من المعادلات التي تؤدي الغرض
      فأصبح لدينا 6 معادلات لعمل المطلوب وكذلك 6 دوال معرفة لعمل المطلوب بالكود
      تابعونا
         
      للإجابة عن هذا السؤال وأكثر تابعونا في هذا الفيديو
      ونتعرف أيضا على:
      طريقة إنشاء دالة معرفة user defined function في إكسل
      طريقة إنشاء إنشاء إجراء sub في إكسل
      كيفية التعامل مع كل خلية في النطاق بالكود vba
      بدائل دالة transpose تعمل على جميع إصدارات إكسل
      تخزين قيم الخلايا في مصفوفة واستعادتها مرة أخرى
      نسخ المعادلات مهما تغير مصدر البيانات في الجدول
      والمفاجأة الكبرى أن جميع ما سبق يتم بالمعادلات في أي مكان تريده ويتم  بالكود وفي نفس المكان
      Flip range horizontal in place by VBA
      Flip range vertical in place by VBA
      Flip range diagonal in place by VBA
      Rotate range left in place by VBA
      Rotate range right in place by VBA
      Transpose range in place by VBA
      ……
        والكثير من المهارات الأساسية في فيجوال بيسك للتطبيقات وفي معادلات إكسل
      لا أريد أن أطيل عليكم تابعوا معي هذا الفيديوتدوير وانعكاس الجداول في إكسل flip rotate transpose tables in excel الشرح يعمل في إكسل 2016 و 2013 و 2010 و 2007

       
      رابط الملف المستعمل في الشرح
      في المرفقات أو من هـــــنــــــــا
        للمزيد زوروا ميكروسوفت إكسل Microsoft excel
       
      ولا ينقصني سوى دعاؤكم لي ولأهلي وأحبابي -وأنتم منهم- بخيري الدنيا والآخرة.
       
      ومشاركة الموضوع مع من يهمه الأمر
      لو بخل بها غيرك ما وصلت إليك
      ولا تنس تقييم المنشور
      rotate flip transpose range formula and vba.rar
  • المتواجدين الان   0 اعضاء متواجدين الان

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

×