نجوم المشاركات

السلام عليكم أخي الكريم تفضل المرفق به المطلوبترقيم2.xlsx

وعليكم السلام-اهلا بك بالمنتدى ... تفضل لك ما طلبت AA-1-Modified101.xlsm

وعليكم السلام -تفضل هذا من أفضل البرامج للأستاذ محمد الريفى له منا كل المحبة والإحترام برنامج المصروفات - الاصدار الثالث

السلام عليكم أخي الكريم تفضل المرفق به الدالة المطلوبة توزيع الافواج على القاعات2.xlsx

من رخصة استاذي العزيز kanory تفضل التعديل ارجو ان يكون طلبك test-6.rar

جرب هذا الكود Sub get_data() Dim rg As Range Dim ro Sheets("AddShe").Range("A1").CurrentRegion.ClearContents Set rg = Sheets("DatabaseShe").Range("a1").CurrentRegion Sheets("AddShe").Range("A1"). _ Resize(rg.Rows.Count, rg.Columns.Count).Value = _ rg.Value Sheets("AddShe").Range("A1"). _ CurrentRegion.Sort key1:=Range("B2"), Header:=1 ro = Sheets("AddShe").Range("a1").CurrentRegion.Rows.Count Sheets("AddShe").Range("A2").Resize(ro - 1) = _ Evaluate("row(1:" & ro - 1 & ")") End Sub الملف مرفق Saleh.xlsm

هذه طريقة اخرى -------->>>>> والطرق كثيرة كما خطرة فكة ممكن عملها ... test-5.accdb

هل هذا هو المطلوب -------->>>> kan_3987.accdb

البحث يمكن ان يكون فقط في السجلات التي تم تصفيتها وابرازها في النموذج/النموذج الفرعي ، يعني البحث يكون على البيانات الظاهرة امامنا ، وسبب ظهور هذا الكم من البيانات هو العلاقة بين النموذج الرئيسي والفرعي عن طريق الحقل id . بينما لو تم حذف هذه العلاقة (طبعا هذه افتراضية) ، فسنرى جميع السجلات ، وعليه يكون البحث لجميع هذه السجلات 🙂 . بمعنى آخر ، اي عدد من البيانات يكون في النوذج الفرعي ، يمكن البحث فيه 🙂 جعفر

الشكر لله استاذ AboBahaa وصاحب الفضل استاذ علاء محمد علي انا فقط قمت بتعديل بسيط

تفضل -------->>> test-5.accdb

مشاركة مع اساتذتي واحبتي تفضل هذه المحاولة ارجو ان تكون طلبك ملاحظة : التعديل مبني على تعديل استاذ علاء المؤهلات الجامعية-22.rar

انا بالخدمة استاذ Ahmed_J

المؤهلات الجامعية.rar

أسأل الله تعالى أن يستجيب دعواتك الطيبة أخي العزيز مصطفى، ولك مثل ذلك. آمين وإياكم أخي الحبيب أبو عاصم. بخصوص الترقيم: هذه الخاصية متوفرة في Word يمكنك تطبيق ما هو مشروح في الصورة التالية، وبعد ذلك تستطيع الترقيم أو التلوين أو فعل أي شيء آخر. بخصوص كتابة رقم في موضع معين: لم أفهم الفكرة بشكل جيد، هل المقصود ترقيم تلقائي أم ماذا؟

رأيتها الآن، ما شاء الله، لا قوة إلا بالله، ممتاز، بارك الله فيك. وعندي اقتراح آخر: وهو ترقيم الكتب والأبواب والأحاديث، أو الفقرات، أو ما إلى ذلك. والطريقة هي: - يجعل الباحث علامة أمام الكتاب، ولتكن مثلا * - وكذلك علامة أمام الباب، ولتكن مثلا @ - وعلامة أما الحديث، ولتكن مثلا = أو أي علامة يختارها، بحيث لا تتكرر في الملف إلا في المواضع المطلوب ترقيمها. - يقوم البرنامج بالترقيم على هذه المواضع المحددة. - كما يضاف إلى البرنامج شكل الرقم، بحيث يوضع مثلا بين []، أو {}، أو ()، أو يترك بلا أقواس، ويوضع بعده شرطة - أو لا يوضع. - ويستحسن إضافة خاصية التلوين للأرقام، فهذه تساعد في حالة المراجعة. ويا حبذا لو أضفت خاصية كتابة رقم في موضع معين، كأرقام المخطوطات مثلا، فنضغط على زر معين فيضيف رقم [1/1]، ثم [1/2]، ثم [1/3]، وهكذا، مع إمكانية إضافة رمز للترقيم، مثل [10 أ]، أو [10 ب]، أو [10 ج]. مع إمكانية إعادة بدء الترقيم، بحيث لو سقط رقم من المخطوط يتم تداركه يدويا.

وعليكم السلام 🙂 قمت بتغيير اسم زر الامر (2) الى cmd_Find_in_SubForm ، فيصبح الكود على حدث النقر على هذا الزر: Private Sub cmd_Find_in_SubForm_Click() 'نقل التركيز على النموذج الفرعي Me.sub_tb_f.SetFocus 'اختيار الحقل الذي نريد ان نجري عليه البحث DoCmd.GoToControl "no" 'نافذة البحث حسب الاعدادات اعلاه DoCmd.RunCommand acCmdFind End Sub . ولكن للتحكم بإعدادات نافذة البحث : . فنستطيع عن طريق الكود التالي: . والتفاصيل : . وبالإعدادات التالية: نحصل على التافذة التالية، وسبب ظهور الرقم 76 هو انه اول رقم يحصل عليه في البحث: . وعند جمع كود التحكم في نافذة البحث ، مع كود البحث ، يكون الكود هكذا : Private Sub cmd_Find_in_SubForm_Click() 'نقل التركيز على النموذج الفرعي Me.sub_tb_f.SetFocus 'اختيار الحقل الذي نريد ان نجري عليه البحث DoCmd.GoToControl "no" 'التحكم في اعدادات نافذة البحث DoCmd.FindRecord 0, acEntire, False, acSearchAll, False, acAll, True 'نافذة البحث حسب الاعدادات اعلاه DoCmd.RunCommand acCmdFind End Sub جعفر

بالخدمة استاذ Ahmed_J تفضل التعديل ملاحظة : الافضل في المستقبل وضع مشاركة جديدة لطلب جديد لانه قد نكون مخالفين لقواعد المشاركة في الموقع واعتذر من المشرفين اذا حدث هذا التجاوز test-5.rar

اتفضل الملف لعله يفى بالغرض والعمود p تم الغاءه تفرير شهرى.xlsm

جربي هذا الملف لا ضرورة لادراج التسلسل لان الكود يدرجه اوتوماتيكياُ في كل صفحة جسب احر رقم موجود فيها الأعمدة التي تحتوي على مغادلات تم اخفائها (في الشيت Main فقط) لعدم العبث بها عن طريق الخطأ أثناء كتابة البيانات (المعادلات محمية ضد الكتابة عليها) المعادلات في الشيت Main فقط الماكرو يقوم بنقل قيمها فقط الى الشيت التي اخترتها) لذلك لا حاجة لادراحها في كل شيت لا تقومي بحذف البيانات (من خلال تجدديد الصف بأكمله تم Delete )لأن ذلك يمسح المعادلات في الأعمدة التي تحتويها (H,Y,AM.AN) تم التعديل على المعادلات لعدم ادراج الأصفار والأخطاء يمكنك تصحيح الاخطاء في الخلايا التي لا تحتوي على معادلات /// كل الأعمدة ما عدا (H,Y,AM.AN) //// هذه الاعمدة مخفية لا تعملي Select يمس بها ثم Delete ) الزر Clear data يمسح كل شيء ما عدا المعادلات يمكن استعماله متى تريدين الملف مرفق ي Om_hamza.xlsb

حقيقة إضافة نوعية للـ (البيان البحثية) وفقكم الله أخي الفاضل/ شحادة بشير، إن شاء الله يكون هذا العمل في ميزان حسناتكم.

عليكم السلام والرحمة تفضل هذا التعديل ارجو ان يكون طلبك test-4.rar

استاذي ومعلمي جعفر اشكركم على تهنئتكم ،،،، العين ما تعلى على الحاجب ، فأنتم نجومنا في السماء ، ونحن تلاميذكم المقصرين ، أشكر لك التهنئة سررت بها .

تفضل اتمنى ان هذا هو ما تريد علاء المؤهلات الجامعية.rar

السلام عليكم ورحمة الله وبركاته تم تنفيذ اقتراحك أخي العزيز أبو عاصم المصري، وهذا فيديو يشرح كل شيء في خاصية فهرس المصادر والمراجع: [الجديد في التحديث 4.00]: 1- في قائمة إزالة، تم إضافة خاصية جديدة لإزالة المسافات البيضاء الزائدة قبل أو بعد الأقواس. 2- في قائمة معلومات، تم إضافة خاصية لفتح موقع قالب وورد الافتراضي. 3- في الفهرسة اليدوية، تم إضافة خاصية جديدة لإدراج فهرس المصادر والمراجع، تتمكن من خلالها من إدخال بيانات الكتب، ومن ثم إدراجها في فهرس المصادر والمراجع بطريقة التوثيق التي تختارها.

لا شكر على واجب نحن في خدمة المنتدى في اي وقت اللي وضح لي من طلبك انك تريد عندما يكون الطالب مكمل او ناجح او راسب تتحول الخلية تلقائيا بدون كتابة لكن هل تقصد تريد تحويل الرقم من 49 الى 50 عندما يكون الطالب لديه ثلاث مواد اقل من 50 مثلا وتريد ان تحولها الى 50 درجة نضغطة زر على كل حال اشرح لي الغاية التي تريدها نشكل واضح حتى افهمها جيدا وان شاء الله لا يوجد شيء مستحيل

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

السلام عليكم ورحمة الله وبركاته كل عام وانتم بخير اطلب المسامحة ممن راسلني ولم يجد رد مني هديتي لكم بعد هذه الغيبة Option Explicit '========================================================" ' بسم الله الرحمن الرحيم " '========================================================" ' (دالة تحويل الرقم الى نص باللغة العربية (تفقيط " ' kh_TextNum " '========================================================" 'Num الرقم " '========================================================" 'sex جنس العملة " 'FALSE ( فارغ او صفر مذكر ) " 'TRUE ( أو اي رقم غير الصفر مؤنث ) " '========================================================" 'sNameCurr اسم العملة الرئيسية مفرد " 'pNameCurr اسم العملة الرئيسية جمع " 'NameCurrDec اسم العملة الكسرية " 'Decimal_Count طول الكسر افتراضـياً : بدون اظهار الكسر " '===============================================================================================================================================" 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" '===============================================================================================================================================" ' ملاحظات ' (اولاً : العملة الرئيسية مثنى (يقوم بها الكود تلقائيا ' مع ملاحظة اذا اسم العملة ينتهي بالتاء المربوطة ' يجب ان يكتب كذلك وليس بالهاء ' ----------------------- ' ثانياً : اذا كانت العملة الرئيسية مفرد فارغاً تعتبر ' اسماء العملات (الجمع والكسري) فارغة تلقائيا ' ----------------------- 'ثالثاً : الكلمة الابتدائية بامكانك تغييرها او تجعلها فارغة Private Const MyBegTx As String = "فقط " ' "" ' ----------------------- ' MyTNum رابعا : يمكنك التغيير (اضافة,حذف,تحرير) في الثابت ' للفئات الصفرية للرقم ادناه Private Const MyTNum As String = "ألف-آلاف/مليون-ملايين/مليار-مليارات/بليون-بلايين/بليار-بليارات/ترليون-ترليونات/تريليار-تريليارات/كدرليون-كدرليونات" '===============================================================================================================================================" 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" '===============================================================================================================================================" Function kh_TextNum(Num As String, Optional sex As Boolean = False, Optional sNameCurr As String = "", Optional pNameCurr As String = "", Optional NameCurrDec As String = "", Optional Decimal_Count As Byte = 2) As String Dim Spp, zt Dim i%, ii%, pr% Dim MyMid$, nCurr$, Txt$, Txt1$, Txt2$ '====================================== If Not IsNumeric(Num) Then GoTo kh_Exit Spp = Split("/" & MyTNum, "/") ii = UBound(Spp) If Num < 0 Then Num = Abs(Num) '====================================== If Val(Num) > Val(String((ii + 1) * 3, "9") & ".999") Then GoTo kh_Exit '====================================== nCurr = sNameCurr & "-" & IIf(pNameCurr = "", sNameCurr, IIf(sNameCurr = "", "", pNameCurr)) '====================================== Txt1 = Format(Num, String((ii + 1) * 3, "0") & ".000") For i = 0 To ii MyMid = Mid(Txt1, (i * 3) + 1, 3) If MyMid Then zt = Mid(Txt1, (i * 3) + 4, Len(Txt1)) zt = IIf(ii - i, Int(zt), zt) Txt2 = IIf(ii - i, Trim(Spp(ii - i)), nCurr) pr = 1 + IIf(ii - i, 1, CInt(sex)) Txt = Txt & IIf(Len(Txt), " و", "") & kh_nText(MyMid, Txt2, pr, zt, CBool(sNameCurr <> "")) End If If i = ii Then If MyMid = 0 Then Txt = Txt & IIf(Len(Txt), " ", "صفر ") & sNameCurr Next '====================================== Txt = MyBegTx & Txt & kh_dText(Num, sNameCurr, NameCurrDec, Decimal_Count) '====================================== kh_Exit: kh_TextNum = Trim(Txt) End Function ' معالجة العدد من 1 الى 999 لكل فئات الرقم Private Function kh_nText(ByVal iNum As String, ByVal oMm As String, ByVal ibs As Integer, ByVal z As Boolean, ByVal tCu As Boolean) As String Dim Sp Dim Num1%, Num2%, Num3% Dim oM$, S$, S1$, nT$, nT0$, nT1$, nT2$ '====================================== Sp = Split("واحد,إحدى,اثنتان,ثلاث,أربع,خمس,ست,سبع,ثمان,تسع,عشر,إحدى ,اثنتا ", ",") '====================================== If ibs Then S = "ة": Sp(1) = Sp(0): Sp(2) = "اثنان": Sp(11) = "أحد ": Sp(12) = "اثنا " Else S1 = "ة" oM = Trim(Split(oMm, "-")(0)) '====================================== Num1 = Left(iNum, 1) Num2 = Right(iNum, 2) Select Case Num1 Case 1: nT0 = "مائة" Case 2: nT0 = "مائتا" & IIf(ibs = 2, IIf(Num2 < 3, "", "ن"), IIf(Num2 = 0 And oM <> "", "", "ن")) Case 3 To 9: nT0 = Sp(Num1) & "مائة" End Select '========================================= Num1 = Right(iNum, 2) Select Case Num1 Case 1, 2: If nT0 <> "" Then If ibs = 2 Then nT0 = nT0 & " " & oM Case 11 To 99: If oM <> "" Then If ibs Then If z Then oM = oM & "اً" End Select '----------------------------------------- Select Case Num1 Case 1 nT = IIf(oM = "", Sp(0) & S1, oM) oM = IIf(ibs <> 2 And oM <> "", Sp(0) & S1, "") Case 2 nT = IIf(oM = "", Sp(Num1), Replace(oM, "ة", "ت") & IIf(z = 0 And ibs = 2 And tCu, "ا", "ان")) oM = IIf(ibs <> 2 And oM <> "", Sp(Num1), "") Case 3 To 10 oM = Trim(Split(oMm, "-")(1)) nT = Sp(Num1) & S Case 11, 12 nT = Sp(Num1) & Sp(10) & S1 Case 13 To 19 nT = Sp(Num1 - 10) & S & " " & Sp(10) & S1 Case 20 To 99 Num2 = Right(Num1, 1) Num3 = Left(Num1, 1) If Num3 = 2 Then nT1 = "عشرون" Else nT1 = Sp(Num3) & "ون" nT2 = Sp(Num2) & IIf(Num2 > 2, S, "") & " و" & nT1 If Num2 = 0 Then nT2 = nT1 nT = nT2 End Select '====================================== S = IIf(nT = "" Or iNum < 100, "", " و") nT = Replace(nT, Sp(8) & "ة", Sp(8) & "ية") kh_nText = Trim(nT0 & S & nT & " " & oM) '====================================== End Function ' معالجة الكسر Private Function kh_dText(ByVal dNum As String, ByVal NCur As String, ByVal Ndec As String, ByVal co As Byte) As String Dim Td$, Td1$ On Error GoTo 1 If NCur = "" Then Ndec = "" Td = Format(Round(CCur(dNum - Int(dNum)), co), "0." & String(co, "0")) If Td = 0 Or Td = 1 Then Td1 = "": GoTo 1 If Len(Ndec) Then Ndec = " " & Ndec: Td1 = Td * CVar("1" & String(co, "0")) Else Ndec = " " & NCur: Td1 = Td Td1 = " و " & Chr(40) & Td1 & Chr(41) & Ndec 1: kh_dText = Td1 End Function دالة تحويل الرقم الى نص عربي.rar ================================================= الملف المعدل: هذا المرفق بامكانية تفقيط الكسر وامكانية ادخال كلمة نهاية النص دالة تحويل الرقم الى نص عربي.rar ================================================= رابط مباشر للملف

السلام عليكم كما وعدتكم .......... البرنامج جاهز ,,, وهو حسب نظام المملكة الاردنية الهاشمية تستطيعون التعديل عليه بما يتناسب مع منطقتكم من حيث الاسماء والاضافات البرنامج مفتوح المصدر وهو من تصميمي للتواصل والاستفسار عبر الواتس اب 00962787787573 اتمنى لكم الفائدة برنامج المحامي 2019 - Copy.rar

الساده / أعضاء المنتدى المحترمين سلام الله عليكم جميعا ورحمته وبركاته قمت بعمل تجميع لعديد من النماذج الخاصة بالتفقيط سواء كانت بالمعادلات أو بالأكواد وقد قمت بتجميعها من خلال البحث فى المنتدى فسامحونى إن كنت نسيت نموذج لأحد الأساتذه الأعضاء نتمنى من الله عز وجل أن ينتفع بها الجميع تلك النماذج القيمه هى مجهود للساده الأعضاء بارك الله فيهم وزادهم الله من فضله وجزاهم رب العالمين عنا خير الجزاء ونماذج قاموا بتنفيذها بناء على طلبات من الساده الأعضاء وتقبلوا منى وافر الإحترام والتقدير أخيكم فى الله محمود الشريف وإليكم النماذج نموذج للأستاذ / ابراهيم ابو ليله _ بالمعادلات http://www.officena.net/ib/index.php?showtopic=50183#entry307279 نموذج للأستاذ / عبد الله باقشير _ بالكود http://www.officena.net/ib/index.php?showtopic=39447#entry219034 نموذج للأستاذ / عبد الله باقشير _ بالكود مع امكانية تفقيط الكسر http://www.officena.net/ib/index.php?showtopic=39447&page=2#entry219292 نموذج للأستاذ / hrashad _ بالمعادلات التفقيط بالعربية والإنجليزية http://www.officena.net/ib/index.php?showtopic=40054#entry224441 رابط آخر لنفس النموذج http://www.officena.net/ib/index.php?showtopic=40054#entry224516 نموذج للأستاذ / A_ALOMANI _ بالأكواد ( التفقيط بالهلله ) http://www.officena.net/ib/index.php?showtopic=30414#entry251870 نموذج للأستاذ / محمدى عبد السميع _ بالأكواد تفقيط درجات الطلاب تفقيط العملات تفقيط الأصناف http://www.officena.net/ib/index.php?showtopic=41743#entry237240 نموذج للأستاذ / محمدى عبد السميع _ بالأكواد يصلح لكثير من الأعمال ( تفقيط درجات وعملات ) http://www.officena.net/ib/index.php?showtopic=41743#entry237241 نموذج للأستاذ / خالد _ معادلات تصلح لأكسيل 2010 مع شرح لها http://www.officena.net/ib/index.php?showtopic=42069#entry299427 نموذج للأستاذ / ابراهيم ابو ليله عده معادلات وأكواد مع الشرح http://www.officena.net/ib/index.php?showtopic=42215#entry241303 وهذا رابط الشرح http://www.officena.net/ib/index.php?showtopic=42215#entry241306 نموذج للأستاذ / mosaline شرح لتنصيب كود تفقيط يكون دائما بملف الأكسيل أو بالأدق ببرنامج الأكسيل داخل الجهاز مع الكود http://www.officena.net/ib/index.php?showtopic=45879#entry271888 نموذج للأستاذ / hat شرح وتنصيب لكود تفقيط http://www.officena.net/ib/index.php?showtopic=45879#entry273104 نموذج للأستاذ / أبو القبطان _ بالمعادلات _ باللغة الإنجليزية http://www.officena.net/ib/index.php?showtopic=30396#entry152131 نموذج للأستاذ / محمد صالح _ بالمعادلات _ باللغة العربية http://www.officena.net/ib/index.php?showtopic=30396#entry152373 كود للتفقيط بالإنجليزية أرفقة الأستاذ / يحى حسين http://www.officena.net/ib/index.php?showtopic=27127#entry130442 نموذج للاستاذ / نزار سليمان كود التفقيط بالإنجليزية والريال بالإنجليزية http://www.officena.net/ib/index.php?showtopic=27127#entry130464 نموذج للأستاذ / amoudi _ بالمعادلات http://www.officena.net/ib/index.php?showtopic=27127#entry130966 نموذج للأستاذ / يحي حسين _ بالمعادلات http://www.officena.net/ib/index.php?showtopic=27127#entry130968 نموذج للأستاذ / عبد الله باقشير قام بإرفاقه الأستاذ / نزار سليمان http://www.officena.net/ib/index.php?showtopic=27127#entry131252 نموذج للأستاذ / الشهابى _ بالكود تفقيط بالدينار والدرهم http://www.officena.net/ib/index.php?showtopic=41586#entry236035 نموذج للاستاذ / أبو غريب _ معادلات http://www.officena.net/ib/index.php?showtopic=40562#entry228268 نموذج للأستاذ / بن عليه حاجى دمج بين المعادلات والأكواد لتفقيط الرقم السالب أى مثل ( -50) سالب خمسين http://www.officena.net/ib/index.php?showtopic=48014#entry290505 نموذج للأستاذ / مصطفى كمال كود للتفقيط بالدينار الكويتى http://www.officena.net/ib/index.php?showtopic=34584#entry202194 نموذج للأستاذ / محمود على محمود _ بالكود http://www.officena.net/ib/index.php?showtopic=34584#entry202194 نموذج للأستاذ / يحي حسين _ بالمعادلات http://www.officena.net/ib/index.php?showtopic=46925#entry281963

السلام عليكم ورحمة الله وبركاته الاخ الحبيب/ azeem ______حفظه الله جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ الجزيرة______حفظه الله المنتدى منور بشخصك الكريم رجاءك مقبول جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ عبدالله المجرب______حفظه الله المنتدى منور بشخصك الكريم جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ ابوعبدالله______حفظه الله المنتدى منور بشخصك الكريم هذا العمل من ثمرة العمل السابق الذي لك باع كبير في انجازه جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ سعد عابد______حفظه الله نعم صدقت جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ محمد صالح ______حفظه الله تدعوا الله ان يمن علينا وعليكم وعلى جميع المسلمين بالامن والامان تم التنفيذ في الملف المرفق جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ alidroos______حفظه الله الله يكرمك في الدارين جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ معتصم محمد______حفظه الله شكرا جزيلا والغاية من وضع اي عمل هو طرح افكاروطرق مختلفة وانا مستعد لشرح اي جزئية غامضة جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ سعيد______حفظه الله الله يكرمك في الدارين جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ يحياوي______حفظه الله الله يكرمك في الدارين جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ فضل 1______حفظه الله الله يكرمك في الدارين جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ الشهابي______حفظه الله الله يكرمك في الدارين جزاك الله خيرا وبارك الله فيك الاخ الحبيب/نادر______حفظه الله الله يكرمك في الدارين ورجاءك مقبول جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ محمدي______حفظه الله الله يكرمك في الدارين جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ طاهر______حفظه الله الله يكرمك في الدارين جزاك الله خيرا وبارك الله فيك الاخ الحبيب/الحسامي______حفظه الله الله يكرمك في الدارين جزاك الله خيرا وبارك الله فيك الاخ الحبيب/دغيدي______حفظه الله شاهد التعديل في المرفق واي ملاحظات اشعرنا بها جزاك الله خيرا وبارك الله فيك ========================================================================= هذه الدالة مع امكانية تفقيط الكسر Option Explicit '========================================================" ' بسم الله الرحمن الرحيم " '========================================================" ' (دالة تحويل الرقم الى نص باللغة العربية (تفقيط " ' kh_TextNum " '========================================================" 'Num الرقم " '========================================================" 'Sex جنس العملة " ' FALSE ( أو فارغ او صفر مذكر ) " ' TRUE ( أو اي رقم غير الصفر مؤنث ) " '========================================================" 'NCurr_Si اسم العملة الرئيسية مفرد " 'NCurr_Pl اسم العملة الرئيسية جمع " 'NCurrDec_Si اسم العملة الكسرية " 'Decimal_Count طول الكسر افتراضـياً : بدون اظهار الكسر " '========================================================" ' : للدلالة على تفقيط الكسر عين التالي " 'NCurrDec_pl اسم العملة الكسرية جمع " 'dSex جنس عملة الكسر " ' FALSE ( أو فارغ او صفر مذكر ) " ' TRUE ( أو اي رقم غير الصفر مؤنث ) " '========================================================" 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" ' ملاحظات ' (اولاً : العملة الرئيسية مثنى (يقوم بها الكود تلقائيا ' مع ملاحظة اذا اسم العملة ينتهي بالتاء المربوطة ' يجب ان يكتب كذلك وليس بالهاء ' ----------------------- ' ثانياً : اذا كانت العملة الرئيسية مفرد فارغاً تعتبر ' اسماء العملات (الجمع والكسري) فارغة تلقائيا ' ----------------------- '("" ثالثاً : امكانية إضافة كلمة بداية ونهاية النص (فارغة Private Const MyBegTx As String = "فقط " Private Const MyEndTx As String = "" ' ----------------------- ' MyTNum رابعا : يمكنك التغيير (اضافة,حذف,تحرير) في الثابت ' للفئات الصفرية للرقم ادناه Private Const MyTNum As String = "ألف-آلاف/مليون-ملايين/مليار-مليارات/بليون-بلايين/بليار-بليارات/ترليون-ترليونات/تريليار-تريليارات/كدرليون-كدرليونات" 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" '===============================================================================================================================================" Private Const wow As String * 2 = " و" '===============================================================================================================================================" Function kh_TextNum(Num As String, Optional Sex As Boolean = False _ , Optional NCurr_Si As String = "", Optional NCurr_Pl As String = "" _ , Optional NCurrDec_Si As String = "", Optional Decimal_Count As Byte = 0 _ , Optional NCurrDec_Pl As String = "", Optional dSex As Boolean = False) As String '====================================== Dim Spp, zt Dim i%, ii%, pr% Dim MyMid$, nCurr$, Txt$, Txt1$, Txt2$ '====================================== If Not IsNumeric(Num) Then GoTo kh_Exit If Num = 0 Then Txt = MyBegTx & "صفر " & NCurr_Si: GoTo kh_Exit '====================================== Spp = Split("/" & MyTNum, "/") ii = UBound(Spp) If Num < 0 Then Num = Abs(Num) '====================================== If Val(Num) > Val(String((ii + 1) * 3, "9") & ".999") Then GoTo kh_Exit '====================================== nCurr = NCurr_Si & "-" & IIf(NCurr_Pl = "", NCurr_Si, IIf(NCurr_Si = "", "", NCurr_Pl)) '====================================== Txt1 = Format(Num, String((ii + 1) * 3, "0") & ".000") For i = 0 To ii MyMid = Mid(Txt1, (i * 3) + 1, 3) If MyMid Then zt = Mid(Txt1, (i * 3) + 4, Len(Txt1)) zt = IIf(ii - i, Int(zt), 1) Txt2 = IIf(ii - i, Trim(Spp(ii - i)), nCurr) pr = 1 + IIf(ii - i, 1, CInt(Sex)) Txt = Txt & IIf(Len(Txt), wow, "") & kh_nText(MyMid, Txt2, pr, zt, CBool(NCurr_Si <> "")) End If If i = ii Then If MyMid = 0 Then Txt = Txt & IIf(Len(Txt), " " & NCurr_Si, IIf(Decimal_Count = 0, "صفر", "")) Next '====================================== Txt = MyBegTx & Txt & kh_dText(Num, NCurr_Si, Trim(NCurrDec_Si), Decimal_Count, Trim(NCurrDec_Pl), dSex) & MyEndTx '====================================== kh_Exit: kh_TextNum = Trim(Txt) End Function ' معالجة العدد من 1 الى 999 لكل فئات الرقم Private Function kh_nText(ByVal iNum As String, ByVal oMm As String, ByVal ibs As Integer, ByVal Z As Boolean, ByVal tCu As Boolean) As String Dim Sp Dim Num1%, Num2%, Num3% Dim oM$, S$, S1$, nT$, nT0$, nT1$, nT2$ '====================================== Sp = Split("واحد,إحدى,اثنتان,ثلاث,أربع,خمس,ست,سبع,ثمان,تسع,عشر,إحدى ,اثنتا ", ",") '====================================== If ibs Then S = "ة": Sp(1) = Sp(0): Sp(2) = "اثنان": Sp(11) = "أحد ": Sp(12) = "اثنا " Else S1 = "ة" oM = Trim(Split(oMm, "-")(0)) '====================================== Num1 = Left(iNum, 1) Num2 = Right(iNum, 2) Select Case Num1 Case 1: nT0 = "مائة" Case 2: nT0 = "مائتا" & IIf(ibs = 2, IIf(Num2 < 3, "", "ن"), IIf(Num2 = 0 And oM <> "", "", "ن")) Case 3 To 9: nT0 = Sp(Num1) & "مائة" End Select '========================================= Num1 = Right(iNum, 2) Select Case Num1 Case 1, 2: If nT0 <> "" Then If ibs = 2 Then nT0 = nT0 & " " & oM Case 11 To 99: If oM <> "" Then If ibs Then If Z Then oM = oM & "اً" End Select '----------------------------------------- Select Case Num1 Case 1 nT = IIf(oM = "", Sp(0) & S1, oM) oM = IIf(ibs <> 2 And oM <> "", Sp(0) & S1, "") Case 2 nT = IIf(oM = "", Sp(Num1), Replace(oM, "ة", "ت") & IIf(Z = 0 And ibs = 2 And tCu, "ا", "ان")) oM = IIf(ibs <> 2 And oM <> "", Sp(Num1), "") Case 3 To 10 oM = Trim(Split(oMm, "-")(1)) nT = Sp(Num1) & S Case 11, 12 nT = Sp(Num1) & Sp(10) & S1 Case 13 To 19 nT = Sp(Num1 - 10) & S & " " & Sp(10) & S1 Case 20 To 99 Num2 = Right(Num1, 1) Num3 = Left(Num1, 1) If Num3 = 2 Then nT1 = "عشرون" Else nT1 = Sp(Num3) & "ون" nT2 = Sp(Num2) & IIf(Num2 > 2, S, "") & wow & nT1 If Num2 = 0 Then nT2 = nT1 nT = nT2 End Select '====================================== S = IIf(nT = "" Or iNum < 100, "", wow) nT = Replace(nT, Sp(8) & "ة", Sp(8) & "ية") kh_nText = Trim(nT0 & S & nT & " " & oM) '====================================== End Function ' معالجة الكسر Private Function kh_dText(ByVal dNum As String, ByVal NCur As String, ByVal Ndec As String, ByVal co As Byte, ByVal Ndec_pl As String, ByVal dsx As Boolean) As String Dim Td$, dwow$, Td1$ On Error GoTo 1 If co = 0 Then GoTo 1 If NCur = "" Then Ndec = "" Td = Format(Round(CCur(dNum - Int(dNum)), co), "0." & String(co, "0")) If Td = 0 Or Td = 1 Then Td1 = "": GoTo 1 If Int(dNum) Then dwow = wow If Len(Ndec) Then Ndec = " " & Ndec Td1 = Td * CVar("1" & String(co, "0")) If Len(Ndec_pl) And co < 4 Then Td1 = dwow & kh_nText(Format(Td1, "000"), Ndec & "-" & Ndec_pl, 1 + CInt(dsx), 1, 0): GoTo 1 Else Ndec = " " & NCur: Td1 = Td End If Td1 = dwow & " " & Chr(40) & Td1 & Chr(41) & Ndec 1: kh_dText = Td1 End Function دالة تحويل الرقم الى نص عربي.rar

السلام عليكم اليك هذا المرفق من عمل اخي الحبيب خبور جزاه الله خيرا مع الشكر ابو خالد __________________.rar

السلام عليكم و رحمة الله و بركاته هذا ايضاً ملف اخر للتفقيط بدون كود NumsToWords_No_VBA.zip

السلام عليكم جزاك الله خيرا اخي justice اخي yalla مرفق ملف من عمل احد الاخوة بالمنتدى وقمت بتعديل بسيط على العملة ليتناسب الدولار والريال مع الشكر ابو خالد Nizar_Arabic___English.rar