اذهب الي المحتوي
أوفيسنا

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


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

بسم الله الرحمن الرحيم

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

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

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

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

والسؤال بعد طلب الإذن من حضراتكم كيف يمكن تعديل هذه الأسطر من الكود

ممنوع رفع الملف مضغوط طالما حجمه صغير ... تم تعديل رفع الملف بدون ضغط تجنباً لإهدار وقت الأساتذة

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

رابط هذا التعليق
شارك

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

اخي أبو سجدة

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

    

 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

رابط هذا التعليق
شارك

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

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

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

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

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

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

رابط هذا التعليق
شارك

اخي أبو سجدة

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

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

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

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

رابط هذا التعليق
شارك

أخى محمد 

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

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

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

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

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

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

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

  • Like 1
رابط هذا التعليق
شارك

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

اجعل الكود هكذا

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

 

  • Like 1
رابط هذا التعليق
شارك

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

الحاقا بالمشاركة السابقة ( بعد ان وقع سهوا)

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

 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

رابط هذا التعليق
شارك

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

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

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

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

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

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

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

 

رابط هذا التعليق
شارك

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

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

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

بتلك الفقرة

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

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

 

رابط هذا التعليق
شارك

  • 4 weeks later...

بعد إذن جميع الأخوة المشاركين 

هذا جهدي المتواضع لإثراء الموضوع

يمكن اختصار الإجراء لهذا الكود

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

 

  • Like 3
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information