ابو مارفن

للرفع

Private Sub Worksheet_Change(ByVal Target As Range) 'لادراج بيانات الاسم في حال تكراره If Target.Column = 2 And Target.Row > 1 Then Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlManual Dim rw& On Error Resume Next rw = Range("q:q").Find(Target.Value, Target, , 1, , 2).Row Target.Offset(, 1).Value = Cells(rw, 3).Value Target.Offset(, 2).Value = Cells(rw, 4).Value Target.Offset(, 3).Value = Cells(rw, 5).Value Target.Offset(, 4).Value = Cells(rw, 6).Value Target.Offset(, 5).Value = Cells(rw, 7).Value Target.Offset(, 6).Value = Cells(rw, 8).Value Target.Offset(, 7).Value = Cells(rw, 9).Value Target.Offset(, 8).Value = Cells(rw, 10).Value Target.Offset(, 9).Value = Cells(rw, 11).Value Application.Calculation = xlAutomatic Application.EnableEvents = True Application.ScreenUpdating = True End If End Sub

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

للرفع

اللهم إنا نسألك بأسمائك الحسنى وبصفاتك العلا وبرحمتك التي وسعت كلّ شيء، أن تمنّ عليه بالشفاء العاجل، وألّا تدع فيه جرحاً إلّا داويته، ولا ألماً إلا سكنته، ولا مرضاً إلا شفيته، وألبسه ثوب الصحة والعافية عاجلاً غير آجل، وشافِه وعافِه واعف عنه، واشمله بعطفك ومغفرتك، وتولّه برحمتك يا أرحم الراحمين.َ

للرفع

بالتاكيد شكرا جزيلا لصاحب الكود الاستاذ عبدالله باقشير ولجميع القائمين على هاذا المنتدى العريق تفقيط الكود 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

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