ابو مارفن

بالتاكيد شكرا جزيلا لصاحب الكود الاستاذ عبدالله باقشير ولجميع القائمين على هاذا المنتدى العريق تفقيط الكود 101000 فقط مائة الف والف دينار لاغيرها التفقيط الصحيح فقط مائة والف دينار لاغيرها تفقيط الكود 102000 فقط مائة الف والفا دينار لاغيرها التفقيط الصحيح فقط مائة والفان دينار لاغيرها مع جزيل الشكر لجهودكم تفقيط الرقم.xlsm

الملف المرفق Option Explicit '========================================================" ' بسم الله الرحمن الرحيم " ' تم تحميل هذا الكود من الرابط التالي ' http://www.officena.net/ib/topic/39447-%D8%AF%D8%A7%D9%84%D8%A9-%D8%AA%D9%81%D9%82%D9%8A%D8%B7-%D8%AA%D8%AD%D9%88%D9%8A%D9%84-%D8%A7%D9%84%D8%B1%D9%82%D9%85-%D8%A7%D9%84%D9%89-%D9%86%D8%B5-%D8%A8%D8%A7%D9%84%D8%B9%D8%B1%D8%A8%D9%8A-%D8%B7%D9%88%D9%84-%D8%A7%D9%84%D8%B1%D9%82%D9%85-%D8%BA%D9%8A%D8%B1-%D9%85%D8%AD%D8%AF%D9%88%D8%AF/ ' الكود من كتابة السيد عبد الله باقشير بتاريخ 27/11/2011 ' تم التعديل على اسم الكود مع القيم الافتراضية للتتناسب مع العملة السعودية ' كذلك تم تعديل ترتيب مدخلات الدالة لسهولة الحفظ للمستخدم النهائي ' تم التعديل من قبل حسين بلال بتاريخ 22/2/2016 ' husseinb[at]viaexcel.com ' www.viaexcel.com ' CurrText '========================================================" ' (دالة تحويل الرقم الى نص باللغة العربية (تفقيط " ' 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 melad(Num As String, _ Optional Sex As Boolean = False, _ Optional NCurr_Si As String = "دينار", _ Optional NCurr_Pl As String = "دينار", _ Optional dSex As Boolean = False, _ Optional NCurrDec_Si As String = "فلس", _ Optional NCurrDec_Pl As String = "فلس", _ Optional Decimal_Count As Byte = 3) _ 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: melad = 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 تفقيط الرقم.xlsm

السلام عليكم ممكن التفضل بتعديل كود تفقيط المبلغ 101000 فقط مائة الف والف دينار لاغيرها 102000 فقط مائة الف والفا دينار لاغيرها مع جزيل الشكر تفقييط.xlsx

ابحث في المواضيع المثبتة تحتوى على شرح مفصل

استاذ محمد العزيز عند معاينه الصفحة لطباعتها لا يظهر المجموع بنهاية الورقة عند معاية الطباعة هل يمكن احتواء الصفوف للطباعة الورقة تلقائيا مهما كان حجم الصفوف المختارة او عددها مع جزيل الشكر تعديل للتنفيد على مصنف خارجي-6.rar

عاشت ايدك ومشكور استاذي العزيز على جهودك الله يحفظك ويرحم امواتك ويجعلها بميزان حسناتك تحياتي لحضرتك

مشكور استاذي العزيز الله يحفظك ويبارك بجهودك ابدعت بس فاصل الصفحات ان يكون بين المجموع والمدور اي ان يكون المجموع في اخر صف الصفحة والمدور ان يكون بداية الصفحة التالية ومشكور على جهودك

السلام عليكم محتاج تعديل على الكود لاضافة حقل المدور في بداية كل صفحة جديده يحتوى على مجموع الصفحة السابقة لكي يتم جمعه مع الصفحة التالية وفي الورقة الاخيرة يكون المجموع الكلي لجميع الصفحات لكي يقوم الكود بتنفيذ كما هو موضح في صفحة البيانات مع جزيل الشكر والتقدير معاهد.xlsm تحديد عدد صفوف للصفحة ومجموعها.xlsm

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

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

TEST 1.rar

غدا سارفع ملف توضيح للمطلوب قبل التنفيذ والنتيجة تقبل تحياتي

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

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

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