ترقية UDF

**سليم حاصبيا** · أكتوبر 26, 2018

نزولاُ عند رغبة بعض الأصدقاء و متابعة للموضوع على هذا العنوان ( المراتب من 1 الى مئة)

http://www.officena.net/ib/topic/84849-المراتب-من-1-الى-100/
تم زيادة النطاق لغاية الرقم 1000
و بذلك يكتب لك الاكسل مثلاً الرقم 125 (مئة وخمسة وعشرون) : الرقم 934 (تسعمئة وأربعة وثلاثون)

الكود


Option Explicit

Function Order_Salim(cel)
Dim degree$, i%, My_num1%, My_num2%
Dim aHad$, Asharat$
If Not IsNumeric(cel) Then Order_Salim = "N/A": Exit Function
 If cel = 100 Then
  Order_Salim = "المائة": Exit Function
 End If
 If cel > 100 Then
  Order_Salim = "too Big Number": Exit Function
 End If
cel = Int(Abs(cel))
Dim deg1$, deg2$, deg3$, deg4$, deg5$, deg6$, deg7$, deg8$, deg9$, deg10$
   deg1 = "الأوّل": deg2 = "الثّاني": deg3 = "الثّالث": deg4 = "الرّابع"
   deg5 = "الخامس": deg6 = "السّادس": deg7 = "السّابع": deg8 = "الثّامن": deg9 = "التّاسع": deg10 = "العاشر"
Dim deg01$, deg02$, deg03$, deg04$, deg05$, deg06$, deg07$, deg08$, deg09$
    deg01 = "عشر": deg02 = "والعشرون": deg03 = "والثّلاثون": deg04 = "والأربعون": deg05 = "والخمسون"
    deg06 = "والستون": deg07 = "والسّبعون": deg08 = "والثّمانون": deg09 = "والتّسعون"
    If cel < 11 Then
    Select Case cel
            Case Is = 1:   degree = deg1
            Case Is = 2:   degree = deg2
            Case Is = 3:   degree = deg3
            Case Is = 4:   degree = deg4
            Case Is = 5:   degree = deg5
            Case Is = 6:   degree = deg6
            Case Is = 7:   degree = deg7
            Case Is = 8:   degree = deg8
            Case Is = 9:   degree = deg9
            Case Is = 10: degree = deg10
    End Select
Order_Salim = degree: Exit Function
Else
  My_num1 = Mid(cel, 2, 1)
  '===========================
  Select Case My_num1
                           
        '=======================
            Case Is = 1:   aHad = "الحادي"
            Case Is = 2:  aHad = deg2
            Case Is = 3:   aHad = deg3
            Case Is = 4:   aHad = deg4
            Case Is = 5:   aHad = deg5
            Case Is = 6:   aHad = deg6
            Case Is = 7:  aHad = deg7
            Case Is = 8:  aHad = deg8
            Case Is = 9:  aHad = deg9

  End Select
  '======================
    My_num2 = Mid(cel, 1, 1)
  Select Case My_num2
            Case Is = 1:   Asharat = deg01
            Case Is = 2:   Asharat = deg02
             Case Is = 3:   Asharat = deg03
             Case Is = 4:   Asharat = deg04
             Case Is = 5:   Asharat = deg05
             Case Is = 6:   Asharat = deg06
             Case Is = 7:   Asharat = deg07
            Case Is = 8:    Asharat = deg08
            Case Is = 9:    Asharat = deg09

    End Select
  
     If My_num1 = 0 Then
        Order_Salim = Right(aHad & " " & Asharat, Len(aHad & " " & Asharat) - 2)
        Else
        Order_Salim = aHad & " " & Asharat
    End If
  End If
End Function
 Function OrdeUP100(cel)
 If Not IsNumeric(cel) Or Int(cel) <> cel Or Int(cel) <= 0 Then
 OrdeUP100 = "ERROR": Exit Function
 End If
 If cel = 1000 Then OrdeUP100 = "الألف": Exit Function
 If cel > 1000 Then OrdeUP100 = "Too Large Integer": Exit Function

 Dim Mi3at, Free, Martab1
  If cel <= 99 Then OrdeUP100 = Order_Salim(cel): Exit Function
   Select Case Left(cel, 1)
  Case Is = 1: Mi3at = "مئة"
  Case Is = 2: Mi3at = "مئتين"
  Case Is = 3: Mi3at = "ثلاثمائة"
  Case Is = 4: Mi3at = "أربعمئة"
  Case Is = 5: Mi3at = "خمسمئة"
  Case Is = 6: Mi3at = "ستممئة"
  Case Is = 7: Mi3at = "سبعمئة"
  Case Is = 8: Mi3at = "ثمانمئة"
  Case Is = 9: Mi3at = "تسعممئة"
  End Select
  If Mid(cel, 2, 1) = 0 Then
     Free = Right(cel, 1)
      Select Case Free
       Case 0: Martab1 = ""
       Case 1: Martab1 = " وواحد"
       Case 2: Martab1 = "وإثنين"
       Case 3: Martab1 = "وثلاثة"
       Case 4: Martab1 = "وأربعة"
       Case 5: Martab1 = "وخمسة"
       Case 6: Martab1 = "وستة"
       Case 7: Martab1 = "وسبعة"
       Case 8: Martab1 = "وثمانية"
       Case 9: Martab1 = "وتسعة"
      End Select
      OrdeUP100 = Mi3at & " " & Martab1: Exit Function
      End If

OrdeUP100 = Mi3at & " و" & Order_Salim(Mid(cel, 2, 2) * 1)

 End Function

الملف مرفق

order_up_to_1000.xlsm