عبدالله باقشير

السلام عليكم ورحمة الله وبركاته جمعة مباركة هذه لمسات جديدة على الكود بحيث انه لا يعتمد على الصف الثالث في العد Option Explicit Option Compare Text Sub kh_MaxContDay() Dim i As Integer For i = 7 To Range("B" & Rows.Count).End(xlUp).Row MaxContDay i Next End Sub '========================================= Sub MaxContDay(iRow As Integer) Dim kh, sp Dim MyArr As String, Myitem As String Dim c As Integer, x As Integer, r As Integer For Each kh In Range("B5:AE5").Cells If Cells(iRow, kh.Column).Value = "x" Then MyArr = MyArr & Trim(kh) & " " End If Next sp = Split(Trim(MyArr)): c = UBound(sp) + 1 If c Then For Each kh In sp x = UBound(Filter(sp, CStr(kh))) + 1 If x > r Then r = x: Myitem = kh Next End If Cells(iRow, "AG").Value = Myitem Cells(iRow, "AH").Value = c End Sub المرفق اكسل 2003 اكبر يوم مكرر.rar

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

السلام عليكم لاباس عليك شافاك اللة و عافاك

السلام عليكم جزاكم الله خيرا الجمع المبارك لكم شكري وتقديري

السلام عليكم الاخ / leprince2007 جاري دراسة ما تريده ولكن لا اعرف السبب لا يفتح الفورم عندي في نافذة الفيجوال الظاهر عندي مشكلة في اوفيس 2007 الله اعلم

السلام عليكم استخدم الكود التالي: Sub kh_Formulas_to_Values() Dim Rng As Range For Each Rng In Range("Formulas_to_Values").Areas Rng.Value = Rng.Value Next End Sub ودمتم في حفظ الله

السلام عليكم الشكرواصل لاخواني alidroos عبدالله المجرب تطور ملحوظ في اعمالهما بارك الله فيهما ولاثراء الموضوع لو فرضنا ان لكل ورقة اعدادات مختلفة توضع بداية الكود تضع الكود الرئيسي للتحويل في حدث كل ورقة ولو بنفس الاسم ثم تعمل كود في موديل يجمع الكودين Option Explicit ' كود يجمع الكودين Sub kh_C_Formula() ورقة1.kh_copy_Formula ورقة2.kh_copy_Formula End Sub تفضل المرفق دمج كودين.rar

السلام عليكم ورحمة الله وبركاته الاخ الفاضل/ saadamin______حفظه الله جزاك الله خيرا وبارك الله فيك الاخ الفاضل/leprince2007______حفظه الله جزاك الله خيرا وبارك الله فيك الدالة تقوم بذلك جميع المطلوبات فيها اختيارية ما عدى الرقم مثلا kh_TextNum(2007) الناتج: فقط ألفان وسبعة

السلام عليكم ورحمة الله وبركاته الاخ الحبيب/ محمدي______حفظه الله الله يكرمك في الدارين جزاك الله خيرا وبارك الله فيك الاخ الحبيب/السيد عبد الفتاح______حفظه الله الله يكرمك في الدارين جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ ابو العقاب______حفظه الله جزاك الله خيرا وبارك الله فيك

السلام عليكم الاخ الفاضل/ محمد صالح ______حفظه الله جزاك الله خيرا وبوركت يتم تفقيط الكسر لطول 3 ارقام وليس 2 لاني اعتقد ان الكسر للعملة لا يزيد على 3 ارقام والله اعلم عفوا على هذا السؤال في ماذا تحتاج لتفقيط كسر الى بطول 18 رقم ؟ هل يستخدم في تفقيط شي آخر غير العملات ؟ بالنسبة للطلب ان شاء الله ممكن القيام به فقط يحتاج الى دالة رئيسية اخرى تتعامل مع هذه الدالة على شقين مرة للرقم الصحيح واخرى للكسر وربط النتائج مع بعض. اخبرني اذا كان هناك احتياج لها ساقوم بالعمل تقبل تحياتي وشكري

السلام عليكم ورحمة الله وبركاته الاخ الحبيب/ 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

وعليكم السلام اشرقت الانوار بشخصك الكريم ___حفظك الله كل عام وانت بخير تقبل تحياتي وشكري

السلام عليكم ورحمة الله وبركاته كل عام وانتم بخير اطلب المسامحة ممن راسلني ولم يجد رد مني هديتي لكم بعد هذه الغيبة 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 ================================================= رابط مباشر للملف

السلام عليكم ممكن تستخدم المعادلة التالية: =TEXT(C3;"mmm") ودمتم

السلام عليكم اخي الحبيب يوسف عطا ما ذكرت على بالي اطمئن

السلام عليكم جمعة مباركة الملف الخامس معادلات مختلفة للاحصاء توخذ من نطاق البيانات مباشرة بالاعتماد على رقم الفصل كود للفرز في ورقة البيانات موجود في موديل الورقة الحدث دبل شيك على رؤوس الاعمدة يعطيك فرز تصاعدي وايضا تنازلي اذا كررت الضربة دبل شيك او العكس الاخ كات اذا حملت الملف قبل ماتعمل اي حاجة قم بالضغط على الزر اضافة الفصول ستجد انظر الى الكشوفات ولاحظ عدد المسلمين والمسيحيين في كل صف وهذا عملته بالفرز قبل ادخال ترقيم الفصول الاخ جلال طلبك موجود في الملف ودمتم في حفظ الله توزيع على الفصول م5.rar

http://www.officena.net/team/khboor/kh_image/p22.gif المواضيع الحديثة دورة شرح الفيجول بيسك للتطبيقات VBA عبدالله المجرب [مفاجاة سارة] الدرس الرابع من سلسلة شروحات فيديو " الترحيل " أربعة أجزاء عبدالله المجرب امثلة عن كيفية استخدام أدوات الفورم (( متجدد ان شاء الله)) ضاحي الغريب اضخم كتاب لتعلم الصيغ والدوال في Excel 2007 امين بعض الدروس والتطبيقات على الاكسل فيديو (( متجدد )) قنديل الصياد سلسلة الفارس فى شرح دوال الإكسل ( فيديو ) متجدد رجب جاويش شرح دوال الاكسيل صوت وصورة ( باللغة العربية) ؛ أحمد النجار ؛ جميع النماذج من أكواد ومعادلات الخاصة بالتفقيط محمود_الشريف إنشاء القوائم المنسدلة (دروس للمبتدئين) ياسر خليل سلسلة الفارس فى شرح دوال الإكسل ( فيديو ) متجدد رجب جاويش شرح دوال الاكسيل صوت وصورة ( باللغة العربية) أحمد النجار جميع النماذج من أكواد ومعادلات الخاصة بالتفقيط محمود_الشريف

السلام عليكم مشكور اخي الكريم نطاق التاريخ E4:E43 هو عنوان الخلايا اللي فيها التاريخ انظر الورقة 100 اين تجد التاريخ ؟؟ ومثله نطاق الجمع اما التعليق اللي في الخلية ليس له دخل في اي شي يمكنك حذفه تقبل تحياتي وشكري

السلام عليكم شاهد المرفق اكسل 2003 احصاء الفصل1.rar

السلام عليكم بعد اذن الحبيب طارق ___حفظه الله لقد صممت الدالة kh_Sum_Hijri لحساب الجمع بين فترتين بالتاريخ الهجري Option Explicit Function kh_Sum_Hijri(MyNSheet As String, Firstdate As String, Enddate As String, Rngdate As String, RngSum As String) Dim kh_Calendar As Integer kh_Calendar = Calendar Calendar = vbCalHijri If IsDate(Firstdate) And IsDate(Enddate) Then kh_Sum_Hijri = kh_Sum(CDate(Firstdate), CDate(Enddate), Sheets(MyNSheet).Range(Rngdate), Sheets(MyNSheet).Range(RngSum)) End If Calendar = kh_Calendar End Function ===================================================== Function kh_Sum(d1 As Date, d2 As Date, Rng1 As Range, Rng2 As Range) As Double Dim MySum As Double Dim i As Long With Rng1 For i = 1 To .Rows.Count If CDate(.Cells(i, 1)) >= d1 And CDate(.Cells(i, 1)) <= d2 Then MySum = MySum + Rng2.Cells(i, 1) Next i End With kh_Sum = MySum End Function وقد اضفت ثلاث طرق لطريقة استخدام الدالة في ثلاثة اوراق اختار منها الطريقة التي تريد انقل الكود الذي في الملف الى ملفك لتعمل معك الدالة تفضل المرفق اكسل 2003 جمع قيمة بين تاريخين1.rar

السلام عليكم الملف الرابع هو نفس آلية عمل الملف الثاني والثالث توزيع على الفصول م4.rar

السلام عليكم الملف الثالث هو نفس آلية عمل الملف الثاني من ناحية انه يوضع الكشوفات في نفس الملف في صفحة جديدة تسمى MyShClass ولا يتم تكرارها اثناء الاعادة انما يتم حذفها واعادة اضافتها من جديد الميزات الجديدة وضع ارقام الفصول في عمود الفصل تلقائيا في نطاق البيانات مع ضبط عدد الطلبة بالفصل بشكل دقيق اما ورقة الكشف هي عبارة عن راس الكشف وتذييل الكشف وصف واحد فقط للبيانات كسنبل لوضع تنسيقاتك فيه ملحوظه مهمة لصف البيانات هذا : يجب ان لا تنسق هذا الصف بخاصية التفاف النص حتى يبقى بنفس الارتفاع ولا يعطل كود ضبط الصفحات للطباعة طبعا ستجد قليل من المطلوبات اول الكود يجب وضعها بشكل صحيح '============================================================ '============================================================ ' نطاق البيانات اما ان يكون اسم لنطاق ' او عنوان النطاق مع اسم الورقة Private Const My_Date As String = "MyDate" ' ' "البيانات!$A$6:$Z$1205" ' عمود اسماء الطلبة بالنسبة لنطاق البيانات Private Const CNStudents As Byte = 2 ' عمود الفصل الطلبة بالنسبة لنطاق البيانات Private Const CNClass As Byte = 12 ' نطاق راس كشف الفصل Private Const TopRng As String = "B4:I11" ' نطاق تذييل كشف الفصل Private Const EndRng As String = "B13:I17" '============================================================ '============================================================ تفضلوا وعليكم بالدعاء توزيع على الفصول م3.rar

السلام عليكم الاخ الفاضل /كــــــــــــات _______حفظه الله ما تفضلت به سنجيب عليه في مشاريع الملفات لاحقا بارك الله فيك وشهر مبارك وكل عام وانتم بخير تقبل تحياتي وشكري

السلام عليكم بارك الله فيك اخي يحياوي تقبل تحياتي وشكري

السلام عليكم اخي الكريم شهر مبارك وكل عام وانتم بخير هذا العمل معمول لان يكون بهذا الشكل التغيير فيه سيتطلب تركيز ووقت كبير ممكن تعمل فورم آخر بما تريده تقبل تحياتي وشكري