تفقيط المبالغ على طريقة خانتى القرش والجنيه

**أبو سجده** · مارس 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

السلام عليكم ورحمة الله

اخي أبو سجدة

تفضل ... التعديل

 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

شكرا جزيلا أستاذ محمد *** فضلكم الله تعالى

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

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

المشكله هى أن كسر القرش لا يتم تفقيطه **** فكيف يمكن تعديل الأسطر المشار اليها عاليا برمجيا

للحصول على التفقيط كاملا بالشكل الصحيح **** لمزيد من التوضيح يرجى الأطلاع على هذا المرفق ******* تقبل وافر تقديرى

التفقيط المعدل22222.xlsm

محمد يوسف ابو يوسف · مارس 31, 2021

اخي أبو سجدة

بالفعل الكود بعد التعديل يتم تفقيط القروش

اولاً قبل قل شئ يجب كتابة الكسور بالشكل الاتي .50 - .30 -.75 وهكذا يعني لازم علامة دوت . قبل الكسور

اعد النظر مرة اخري

واخبرني بالنتيجه

**أبو سجده** · مارس 31, 2021

أخى محمد

بداية جزاكم الله خيرا وبارك فيكم

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

قد يبدو الأمر سهلا ولكن عندى ضبابية فى تصويب تلك الأسطر

فى الوضع الطبيعى عندما نقوم بجمع خليتين للجنيهات والقروش فالمعادله المستخدمه على سبيل المثال هى

=IFERROR(BE8+BD8/100;"")

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

تقبل وافر تقديرى واحترامى وجزاكم الله خيرا

**ابراهيم الحداد** · مارس 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

**ابراهيم الحداد** · مارس 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

**أبو سجده** · مارس 31, 2021

جزاكم الله خيرا وبارك فيكم أخى وأستاذى الفاضل / إبراهيم الحداد أبو زيزو

اخى واستاذى الفاضل / ابراهيم الحداد

هناك مشكلة بسيطة حاولت العمل عليها ولكن دون جدوى

قد لا تحتوى خلية القروش على أى منازل عشرية أى تكون نتيجة جمع الإجمالى كعدد صحيح بدون كسر

هنا لا يظهر كلمة جنيها نهاية التفقيط أما فى حالة إحتواء خلية القروش على منازل عشرية فالكود يعمل كما ينبغى

مثالا على ذلك 5000.00 جنيها عند تشغيل الكود يظهر التفقيط ( فقط خمسة ألاف ) والمفترض إضافة جنيها لا غير

فيما عدا ذلك فالكود يعمل بشكل مثالى **** كيف يمكن تصويب هذه الجزئية **** مرة أخرى جزاكم الله خيرا

**ابراهيم الحداد** · أبريل 1, 2021

السلام عليكم ورحمة الله

فى كود التفقيط
استبدل هذه الفقرة

 Else
    .Value = "فقط " & Texte1 & St2

بتلك الفقرة

 Else
     .Value = "فقط " & Texte1 & Stx1 & St2

و تنتهى المشكلة باذن الله

**أبو سجده** · أبريل 2, 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

**أبو سجده** · مايو 1, 2021

بارك الله فيك أخى وأستاذى الفاضل // محمد صالح

تسجيل الدخول

تفقيط المبالغ على طريقة خانتى القرش والجنيه

الردود الموصى بها

أبو سجده

محمد يوسف ابو يوسف

أبو سجده

محمد يوسف ابو يوسف

أبو سجده

ابراهيم الحداد

ابراهيم الحداد

أبو سجده

ابراهيم الحداد

أبو سجده

أ / محمد صالح

أبو سجده

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information