أبو سجده قام بنشر مارس 30, 2021 قام بنشر مارس 30, 2021 بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته يحتوى هذا الملف على كودين أحدهما لتفقيط المبالغ والأخر لإستدعاء التفقيط أسفل نهاية الحدول مباشرة وكلاهما يعمل بشكل جيد فى حالة لو أن المبلغ المراد تفقيطه فى عمود واحد ولكن هذا المرفق يحتوى على عمودين أحدهما للقروش والأخر للجنيهات والسؤال بعد طلب الإذن من حضراتكم كيف يمكن تعديل هذه الأسطر من الكود ممنوع رفع الملف مضغوط طالما حجمه صغير ... تم تعديل رفع الملف بدون ضغط تجنباً لإهدار وقت الأساتذة Texte1 = Ar_WriteDownNumber(Int(Cells(LR, "Q"))) Texte2 = Ar_WriteDownNumber(100 * Cells(LR, "Q") Mod 100) وهذا السطر أيضا If 100 * Sh.Cells(LR, "Q") Mod 100 = 0 Then لنحصل على التفقيط من خلال الخليتين BF و BE برجاء الإطلاع على المرفق التالى والإفاده بحول الله تعالى **** تقبلوا وافر تقديرى وجزاكم الله خيرا التفقيط المعدل.xlsb.xlsm
محمد يوسف ابو يوسف قام بنشر مارس 31, 2021 قام بنشر مارس 31, 2021 السلام عليكم ورحمة الله اخي أبو سجدة تفضل ... التعديل Texte1 = Ar_WriteDownNumber(Int(Cells(LR, "Q"))) Texte2 = Ar_WriteDownNumber(100 * Cells(LR, "P") Mod 100) With Sh.Cells(LR + 2, "C") ''' هنا حدد اين تريد يظهرالتفقيط If 100 * Sh.Cells(LR, "Q") Mod 100 = 0 Then If 100 * Sh.Cells(LR, "P") Mod 100 = 0 Then اخبرني بالنتيجه التفقيط المعدل.xlsb.xlsm
أبو سجده قام بنشر مارس 31, 2021 الكاتب قام بنشر مارس 31, 2021 شكرا جزيلا أستاذ محمد *** فضلكم الله تعالى ليس هذا المقصود **** الكود يعمل بشكل جيد ده لو المبلغ المراد تفقيطه فى خلية واحده بمنازله العشرية ولكن فى حالتنا هذه فستجد أن خلية الجنيهات بدون منازل عشريه وخلية القروش تحتوى على كسر القرش المشكله هى أن كسر القرش لا يتم تفقيطه **** فكيف يمكن تعديل الأسطر المشار اليها عاليا برمجيا للحصول على التفقيط كاملا بالشكل الصحيح **** لمزيد من التوضيح يرجى الأطلاع على هذا المرفق ******* تقبل وافر تقديرى التفقيط المعدل22222.xlsm
محمد يوسف ابو يوسف قام بنشر مارس 31, 2021 قام بنشر مارس 31, 2021 اخي أبو سجدة بالفعل الكود بعد التعديل يتم تفقيط القروش اولاً قبل قل شئ يجب كتابة الكسور بالشكل الاتي .50 - .30 -.75 وهكذا يعني لازم علامة دوت . قبل الكسور اعد النظر مرة اخري واخبرني بالنتيجه
أبو سجده قام بنشر مارس 31, 2021 الكاتب قام بنشر مارس 31, 2021 أخى محمد بداية جزاكم الله خيرا وبارك فيكم لا حظت ذلك جيدا ولكن لا ينبغى أن يكون هناك علامة الدوت فى خلية القروش قد يبدو الأمر سهلا ولكن عندى ضبابية فى تصويب تلك الأسطر فى الوضع الطبيعى عندما نقوم بجمع خليتين للجنيهات والقروش فالمعادله المستخدمه على سبيل المثال هى =IFERROR(BE8+BD8/100;"") فكيف يمكن تضمين الخليتين معا فى الأسطر المراد تصويبها وفى جميع الأحوال شرف لى مشاركتكم الطيبة *** فهل من سبيل لتحقيق ذلك تقبل وافر تقديرى واحترامى وجزاكم الله خيرا 1
ابراهيم الحداد قام بنشر مارس 31, 2021 قام بنشر مارس 31, 2021 السلام عليكم ورحمة الله اجعل الكود هكذا Sub TEST() Dim Sh As Worksheet, LR As Long, Cel As Range Dim Stx1 As String, Stx2 As String, St1 As String, St2 As String, Texte1 As String, Texte2 As String For Each Sh In Worksheets(Array("DATA")) LR = Sh.Cells(Sh.Rows.Count, 17).End(xlUp).Row Stx1 = "جنيها ": Stx2 = "قرشا ": St1 = "و ": St2 = "لا غير" 'كيف يمكن تعديل هذين السطرين لتفقيط خانتى القرش والجنيه الملونه باللون الاصفر Texte1 = Ar_WriteDownNumber(Cells(LR, "Q")) Texte2 = Ar_WriteDownNumber(Cells(LR, "P")) With Sh.Cells(LR + 2, "C") ''' هنا حدد اين تريد يظهرالتفقيط 'وهذا السطر If Len(Texte2) > 0 Then .Value = "فقط " & Texte1 & Stx1 & St1 & Texte2 & Stx2 & St2 Else .Value = "فقط " & Texte1 & St2 End If End With ActiveWindow.SelectedSheets.PrintOut Copies:=1 ' Sh.Range(Sh.Cells(LR + 1, "A"), Sh.Cells(LR + 12, "C")).ClearContents Next Sh End Sub 1
ابراهيم الحداد قام بنشر مارس 31, 2021 قام بنشر مارس 31, 2021 السلام عليكم ورحمة الله الحاقا بالمشاركة السابقة ( بعد ان وقع سهوا) فى كود دالة التفقيط استبدل هذه الفقرة MyNumber = Abs(Number_Value) MyNumber = Int(MyNumber) بتلك الفقرة If Number_Value = Empty Then Number_Value = 0 Else MyNumber = Abs(Number_Value) End If MyNumber = Int(MyNumber) حتى يعمل معك الكود بشكل سليم .... فيصبح الكود كاملاً Public Function Ar_WriteDownNumber(Number_Value As String, Optional Main_Currency As String, Optional Small_Currency As String, Optional Main_To_Small_Factor As Integer) Dim MyNumber Dim MyFractions Dim WordFraction Dim Pr Dim Hu Dim Th Dim PrTh Dim HuTh Dim PrMi Dim HuMi Dim Hu1 Dim Pr2 Dim l Dim Thu_Text As String Dim Mil_Text As String If Val(Main_To_Small_Factor) = 0 Then Main_To_Small_Factor = 100 If Small_Currency = "" Then If Main_To_Small_Factor = 100 Then Small_Currency = " جزء من مائة" Else Small_Currency = " جزء من ألف" End If End If If Number_Value = Empty Then Number_Value = 0 Else MyNumber = Abs(Number_Value) End If MyNumber = Int(MyNumber) If InStr(Number_Value, ".") > 0 Then MyFractions = Mid(Number_Value, InStr(Number_Value, ".") + 1, 3) End If l = Len(MyNumber) Pr = Right(MyNumber, 2) Ar_WriteDownNumber = MyPrimary(Pr) If l > 2 Then Hu = Right(Left(MyNumber, l - 2), 1) If Val(Hu) <> 0 Then If Ar_WriteDownNumber <> 0 Then Ar_WriteDownNumber = MyHundreds(Hu) & " و " & Ar_WriteDownNumber Else Ar_WriteDownNumber = MyHundreds(Hu) End If End If Else GoTo 1 End If If l > 3 Then Th = Right(Left(MyNumber, l - 3), 2) If Val(Th) <> 0 Then Thu_Text = "" If Ar_WriteDownNumber <> 0 Then Ar_WriteDownNumber = MyThousand(Th) & " و " & Ar_WriteDownNumber Else Ar_WriteDownNumber = MyThousand(Th) End If Else Thu_Text = " ألف" End If Else GoTo 1 End If If l > 5 Then HuTh = Right(Left(MyNumber, l - 5), 1) If Val(HuTh) <> 0 Then If Ar_WriteDownNumber <> 0 Then Ar_WriteDownNumber = MyHundreds(HuTh) & Thu_Text & " و " & Ar_WriteDownNumber Else Ar_WriteDownNumber = MyHundreds(HuTh) & Thu_Text End If End If Else GoTo 1 End If If l > 6 Then PrTh = Right(Left(MyNumber, l - 6), 2) If Val(PrTh) <> 0 Then Mil_Text = "" If Ar_WriteDownNumber <> 0 Then Ar_WriteDownNumber = MillionPrimary(PrTh) & " و " & Ar_WriteDownNumber Else Ar_WriteDownNumber = MillionPrimary(PrTh) & Mil_Text End If Else Mil_Text = " مليون" End If Else GoTo 1 End If If l > 8 Then HuMi = Right(Left(MyNumber, l - 8), 1) If Ar_WriteDownNumber <> 0 Then Ar_WriteDownNumber = MyHundreds(HuMi) & Mil_Text & " و " & Ar_WriteDownNumber Else Ar_WriteDownNumber = MyHundreds(HuMi) & Mil_Text End If End If If l > 9 Then Ar_WriteDownNumber = MyNumber 1: If Len(Trim(Ar_WriteDownNumber)) > 0 Then Ar_WriteDownNumber = Ar_WriteDownNumber & " " & Main_Currency Else Ar_WriteDownNumber = "" End If If Len(MyFractions) < 2 Then MyFractions = MyFractions + "0" If Len(MyFractions) < 3 Then MyFractions = MyFractions + "0" If Val(MyFractions) = 0 Then Exit Function If Main_To_Small_Factor = 100 Then Pr2 = Left(MyFractions, 2) Else Pr2 = Mid(MyFractions, 2, 2) End If WordFraction = MyPrimary(Pr2) If Main_To_Small_Factor > 100 Then Hu1 = Left(MyFractions, 1) If Val(Hu1) <> 0 Then If WordFraction <> 0 Then WordFraction = MyHundreds(Hu1) & " و " & WordFraction Else WordFraction = MyHundreds(Hu1) End If End If Else GoTo 2 End If 2 If Main_Currency <> "" Then If Len(Trim(Ar_WriteDownNumber)) > 0 Then Ar_WriteDownNumber = Ar_WriteDownNumber & " و " & WordFraction & " " & Small_Currency Else Ar_WriteDownNumber = WordFraction & " " & Small_Currency End If Else If Len(Trim(Ar_WriteDownNumber)) > 0 Then If Main_To_Small_Factor = 100 Then Small_Currency = " جزء من مائة" Else Small_Currency = " جزء من ألف" End If Ar_WriteDownNumber = Ar_WriteDownNumber & " فاصل " & WordFraction Else Ar_WriteDownNumber = WordFraction & " " & Small_Currency End If End If End Function Private Function MyPrimary(J) Dim myText1 Dim myText2 Dim K K = Right(J, 1) J = Val(J) If J < 20 Then MyPrimary = Choose(J, "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة", "عشرة", "إحدى عشر", "اثنا عشر", "ثلاثة عشر", "أربعة عشر", "خمسة عشر", "ستة عشر", "سبعة عشر", "ثمانية عشر", "تسعة عشر") Else myText1 = Choose(Val(K), "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") myText2 = Choose(Int((J - K) / 10) - 1, "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون") If Not IsNull(myText1) Then MyPrimary = myText1 & " و " & myText2 Else MyPrimary = myText2 End If End If End Function Private Function MyHundreds(J) J = Val(J) MyHundreds = Choose(J, "مائة", "مائتان", "ثلاثمائة", "أربعمائة", "خمسمائة", "ستمائة", "سبعمائة", "ثمانمائة", "تسعمائة") End Function Private Function MyThousand(J) Dim myText1 Dim myText2 Dim K K = Right(J, 1) J = Val(J) If J < 20 Then MyThousand = Choose(J, "ألف", "ألفان", "ثلاثة آلاف", "أربعة آلاف", "خمسة آلاف", "ستة آلاف", "سبعة آلاف", "ثمانية آلاف", "تسعة آلاف", "عشرة آلاف", "إحدى عشر ألفاً", "اثنا عشر ألفاً", "ثلاثة عشر ألفاً", "أربعة عشر ألفاً", "خمسة عشر ألفاً", "ستة عشر ألفاً", "سبعة عشر ألفاً", "ثمانية عشر ألفاً", "تسعة عشر ألفاً") Else myText1 = Choose(K, "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") myText2 = Choose((J - K) / 10 - 1, "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون") If Not IsNull(myText1) Then MyThousand = myText1 & " و" & myText2 & " الف" Else MyThousand = myText2 & " الف" End If End If End Function Private Function MillionPrimary(J) Dim myText1 Dim myText2 Dim K K = Right(J, 1) J = Val(J) If J < 20 Then MillionPrimary = Choose(J, "مليون", "مليونان", "ثلاثة ملايين", "أربعة ملايين", "خمسة ملايين", "ستة ملايين", "سبعة ملايين", "ثمانية ملايين", "تسعة ملايين", "عشرة ملايين", "إحدى عشر مليوناً", "اثنا عشر مليوناً", "ثلاثة عشر مليوناً", "أربعة عشر مليوناً", "خمسة عشر مليوناً", "ستة عشر مليوناً", "سبعة عشر مليوناً", "ثمانية عشر مليوناً", "تسعة عشر مليوناً") Else myText1 = Choose(Val(K), "واحد", "أثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") myText2 = Choose(Int((J - K) / 10) - 1, "عشرون مليون", "ثلاثون مليون", "أربعون مليون", "خمسون مليون", "ستون مليون", "سبعون مليون", "ثمانون مليون", "تسعون مليون") If Not IsNull(myText1) Then MillionPrimary = myText1 & " و " & myText2 Else MillionPrimary = myText2 End If End If End Function التفقيط المعدل2.xlsm 1
أبو سجده قام بنشر مارس 31, 2021 الكاتب قام بنشر مارس 31, 2021 جزاكم الله خيرا وبارك فيكم أخى وأستاذى الفاضل / إبراهيم الحداد أبو زيزو اخى واستاذى الفاضل / ابراهيم الحداد هناك مشكلة بسيطة حاولت العمل عليها ولكن دون جدوى قد لا تحتوى خلية القروش على أى منازل عشرية أى تكون نتيجة جمع الإجمالى كعدد صحيح بدون كسر هنا لا يظهر كلمة جنيها نهاية التفقيط أما فى حالة إحتواء خلية القروش على منازل عشرية فالكود يعمل كما ينبغى مثالا على ذلك 5000.00 جنيها عند تشغيل الكود يظهر التفقيط ( فقط خمسة ألاف ) والمفترض إضافة جنيها لا غير فيما عدا ذلك فالكود يعمل بشكل مثالى **** كيف يمكن تصويب هذه الجزئية **** مرة أخرى جزاكم الله خيرا
ابراهيم الحداد قام بنشر أبريل 1, 2021 قام بنشر أبريل 1, 2021 السلام عليكم ورحمة الله فى كود التفقيط استبدل هذه الفقرة Else .Value = "فقط " & Texte1 & St2 بتلك الفقرة Else .Value = "فقط " & Texte1 & Stx1 & St2 و تنتهى المشكلة باذن الله
أبو سجده قام بنشر أبريل 2, 2021 الكاتب قام بنشر أبريل 2, 2021 جزاكم الله خيرا وبارك فيكم أستاذى الفاضل
أ / محمد صالح قام بنشر أبريل 29, 2021 قام بنشر أبريل 29, 2021 بعد إذن جميع الأخوة المشاركين هذا جهدي المتواضع لإثراء الموضوع يمكن اختصار الإجراء لهذا الكود Sub TEST() Dim Sh As Worksheet, LR As Long, Cel As Range Dim Texte1 As String For Each Sh In Worksheets(Array("DATA")) LR = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row Texte1 = Ar_WriteDownNumber(Cells(LR, "Q") + (Cells(LR, "p") / 100), "جنيها", "قرشا", 100) Sh.Cells(LR + 2, "C").Value = "فقط " & Texte1 ''' هنا حدد اين تريد يظهرالتفقيط ActiveWindow.SelectedSheets.PrintOut Copies:=1 Sh.Range(Sh.Cells(LR + 1, "A"), Sh.Cells(LR + 12, "C")).ClearContents Next Sh End Sub 4
أبو سجده قام بنشر مايو 1, 2021 الكاتب قام بنشر مايو 1, 2021 بارك الله فيك أخى وأستاذى الفاضل // محمد صالح 1
الردود الموصى بها
انشئ حساب جديد او قم بتسجيل دخولك لتتمكن من اضافه تعليق جديد
يجب ان تكون عضوا لدينا لتتمكن من التعليق
انشئ حساب جديد
سجل حسابك الجديد لدينا في الموقع بمنتهي السهوله .
سجل حساب جديدتسجيل دخول
هل تمتلك حساب بالفعل ؟ سجل دخولك من هنا.
سجل دخولك الان