دالة ترقيم (عكس تفقيط) لتحويل التفقيط إلى رقم

[AbuuAhmed]

الدالة لتحويل نتائج دالة التفقيط NoToTxt (لا أعرف كاتبها) إلى أرقام.
وقد كتبتها بناءً على طلب أحد أعضاء منتدى الاكسل.
 

Function NoToTxtRev(ByVal TheTxt As String, MyCur As String, MySubCur As String) As Double
  'AbuuAhmed, last update 2024/12/30
  'Reverse of NoToTxt function
  Dim Pos As Integer, Step As Byte, Part4 As Integer, Part As Byte
  Dim i As Byte, ii As Integer
  Dim Parts(6), a, b, c
  Dim Text As String
  Dim Sum4 As Double, Sum As Double
  Dim Key0, Key1, Key2, Key3
  Dim Sp As Integer
  Dim Pwr As Integer
  
  a = Array("", "مائة", "مائتان", "ثلاثمائة", "أربعمائة", "خمسمائة", "ستمائة", "سبعمائة", "ثمانمائة", "تسعمائة", _
            "", "عشر", "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون", _
            "", "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة")
  
  b = Array("إحدى", "إثنى", "عشرة", "فقط  ", "و ", "ملياران", "مليونان", "ألفان", _
            "ومليار", "ومليون", "وألف", "فقط مليار", "فقط مليون", "فقط ألف", "فقط ")
  c = Array("واحد", "اثنان", "صفر عشر", "فقط ", "و", "اثنان مليار", "اثنان مليون", "اثنان ألف", _
            "وواحد مليار", "وواحد مليون", "وواحد ألف", "واحد مليار", "واحد مليون", "واحد ألف", "")
  
  Key1 = Array("", "مليار", "ملياران", "مليارات")
  Key2 = Array("", "مليون", "مليونان", "ملايين")
  Key3 = Array("", "ألف", "ألفان", "آلاف")
  
  For i = 0 To UBound(b)
    TheTxt = Replace(TheTxt, b(i), c(i))
  Next i
  
  If MyCur & MySubCur <> "" Then
    Pos = InStr(1, TheTxt, MyCur)
    If Pos > 0 Then
      Parts(5) = Replace(Mid(TheTxt, Pos + Len(MyCur)), MySubCur, "")
      TheTxt = Left(TheTxt, Pos - 1)
    Else
      Pos = InStr(1, TheTxt, MySubCur)
      If Pos > 0 Then
        Parts(5) = Replace(TheTxt, MySubCur, "")
        TheTxt = ""
      End If
    End If
  Else
    Pos = InStr(1, TheTxt, "  ")
    If Pos > 0 Then
      Parts(5) = Trim(Mid(TheTxt, Pos + 3))
      TheTxt = Left(TheTxt, Pos - 1)
    End If
  End If
  
  For Part = 1 To 3
    Key0 = IIf(Part = 1, Key1, IIf(Part = 2, Key2, Key3))
                    Pos = InStr(1, TheTxt, Key0(1))
    If Pos = 0 Then Pos = InStr(1, TheTxt, Key0(2))
    If Pos = 0 Then Pos = InStr(1, TheTxt, Key0(3))
    If Pos > 0 Then
      Parts(Part) = Left(TheTxt, Pos - 1)
      Pos = InStr(Pos, TheTxt & " ", " ")
      TheTxt = Mid(TheTxt, Pos)
    End If
  Next Part
  Parts(4) = TheTxt
  
  For i = 1 To 5
    Parts(i) = Trim(Replace(Parts(i), " و", " "))
    Parts(i) = Replace(Parts(i), " احد", " واحد")
  Next i
  
  For Part4 = 0 To 12 Step 3
    Part = Part4 / 3 + 1
    Sum4 = 0
    Sp = 3 - (Len(Parts(Part)) - Len(Replace(Parts(Part), " ", "")))
    If Sp < 1 Then Sp = 1
    For Step = Sp To 3
      Pos = InStr(1, Parts(Part) & " ", " ")
      Text = Trim(Left(Parts(Part), Pos - 1))
      Parts(Part) = Mid(Parts(Part), Pos + 1)
      
      If Text <> "" Then
        For i = 1 To UBound(a)
          Pwr = 10 ^ (3 - Fix((i - 1) / 10) - 1)
          ii = i Mod 10
                
          If Text = a(i) Then
            If Part = 5 Then
              Sum4 = Sum4 + ii * Pwr
            Else
              Sum4 = Sum4 + ii * Pwr * Val("1" & IIf(Part = 5, "", String(9 - Part4, "0")))
            End If
            Exit For
          End If
        Next i
      End If
    
    Next Step
    Sum = Sum + IIf(Part = 5, Sum4 / 100, Sum4)
  Next Part4
  
  NoToTxtRev = Sum
End Function

 

[Foksh]

مشكور على المشاركة الطيبة استاذ أبو أحمد ,,

اسمح لي بمداخلة ، وقد توسع الفكرة لأبعد من ذلك ,,

جربتها على مثال بسيط مثلاً

"مائة وخمسة وعشرون دينار وأربعون فلس" والنتيجة = 125.4

"مئة وخمسة وعشرون دينار وأربعون فلس" والنتيجة = 25.4

"مائة وخمسة وعشرون دينار وأربعين فلس" والنتيجة = 125

"مائة وخمسة وعشرون دينار واربعون فلس" والنتيجة = 125

"مائة وخمسة وعشرين دينار وأربعون فلس" والنتيجة = 105.4

اي باختلاف كتابة التفقيط قد يكون هناك عدة فروقات في النتائج ..

 

 

*- مجرد رأي ، ولكم جزيل الشكر 

[AbuuAhmed]

حياك الله أخي @Foksh وشكرا على المشاركة، الدالة لتحويل نتائج دالة التفقيط NoToTxt فقط بمحاسنها ومساوئها ونطاقها،
الدالة موجودة في ملف الإكسل ضمن مشاركة منتدى الإكسل، الملف به أمثلة كذلك، يستحسن الاطلاع عليه.

[abouelhassan]

شكر وتقدير من اخيك