الجداول المحورية والتفقيط

[seaf mohamed]

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

[Ali Mohamed Ali]

اهلا بك اخ كريم بالمنتدى

كان عليك رفع الملف ولكن تفضل هذا كود للتفقيط

Option Explicit

Public Const vArabic As Byte = 1
Public Const vEnglish As Byte = 2
Public Const vMale As Byte = 0
Public Const vFemale As Byte = 1

Function Delete(S As String, Index, Count As Integer) As String
  Delete = Left(S, Index - 1) + _
           Mid(S, Index + Count, Len(S))
End Function

Function Insert(Source, S As String, Index As Integer) As String
  Dim LPart, RPart As String
  
  LPart = Left(S, Index - 1)
  RPart = Mid(S, Index, Len(S))
  Insert = LPart & Source & RPart
End Function

Function AddAnd(S1, S2, S3, And_ As String, Lang As Byte) As String
  Dim InAnd_, CollectS As String
    
  If Lang = vArabic Then InAnd_ = " " + And_ Else InAnd_ = And_ + " "
  If (S1 <> "") And (S2 <> "") Then And_ = InAnd_ Else And_ = ""
  CollectS = S1 + And_ + S2
  If (CollectS <> "") And (S3 <> "") Then And_ = InAnd_ Else And_ = ""
  AddAnd = CollectS + And_ + S3
End Function

Function S2Double(Single_ As Variant, Sex As Byte) As String
  Dim LLeter As Integer
  Dim K As Byte
  Dim Sngl_1, Sngl_2 As String
  
  K = InStr(1, Single_ & " ", " ")
  Sngl_1 = Left(Single_, K - 1)
  Sngl_2 = ""
  If K < Len(Single_) Then
    Sngl_2 = Mid(Single_, K + 1, Len(Single_))
  End If
  
  If Sngl_2 <> "" Then
    If Right(Sngl_2, 1) = "É" Then
      Sngl_2 = Left(Sngl_2, Len(Sngl_2) - 1) & "ÊÇä"
    Else
      Sngl_2 = Sngl_2 & "Çä"
    End If
  End If
  
  If Sngl_1 <> "" Then LLeter = Asc(Right(Sngl_1, 1))
  
  Select Case LLeter
    Case 201 ' "É"
      Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "ÊÇä"
    Case 236 ' "ì"
      Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "íÇä"
    Case 199 ' "Ç"
      Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "æÇä"
    Case 193 ' "Á"
      If Right(Sngl_1, 2) = "ÇÁ" Then
        If Sex = 1 Then
          Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "æÇä"
        Else
          Sngl_1 = Sngl_1 & "Çä"
        End If
      End If
    Case Else
      If Sngl_1 <> "" Then Sngl_1 = Sngl_1 & "Çä"
  End Select
  
  If Sngl_2 <> "" Then
    S2Double = Sngl_1 & " " & Sngl_2
  Else
    S2Double = Sngl_1
  End If
End Function

Function Fmale(Num, Sex As Byte, Female()) As String
  Dim Two(1 To 4) As String
  Dim InSex As Byte
    
  Two(1) = "ÃÍÏ"
  Two(2) = "ÇËäÇä"
  Two(3) = "ÅÍÏì"
  Two(4) = "É"
      
  Select Case Sex
    Case vMale:
      Select Case Num
        Case 1:             Fmale = Mid(Female(1), 1, 4)
        Case 2:             Fmale = Two(2)
        Case 8:             Fmale = Female(Num) + "í" + Two(4)
        Case 3 To 7, 9, 10: Fmale = Female(Num) + Two(4)
        Case 11:            Fmale = Two(1) + " " + Female(10)
        Case 12:            Fmale = Mid(Two(2), 1, 4) + " " + Female(10)
        Case 13 To 19:      Fmale = Female(Num - 10) + Two(4) + " " + Female(10)
      End Select
    Case vFemale:
      Select Case Num
        Case 1 To 10:       Fmale = Female(Num)
        Case 11:            Fmale = Two(3) + " " + Female(10) + Two(4)
        Case 12:            Fmale = Mid(Female(2), 1, 5) + " " + Female(10) + Two(4)
        Case 13 To 19:      Fmale = Female(Num - 10) + " " + Female(10) + Two(4)
      End Select
    End Select
End Function

Function Tens(Num As Byte, Female()) As String
  Const Noon = "æä"
      
  Select Case Num
    Case 2:      Tens = Female(10) + Noon
    Case 3 To 9: Tens = Female(Num) + Noon
  End Select
End Function

Function Hunds(Num As Byte, Female()) As String
  Const Hund = "ãÇÆÉ"
      
  Select Case Num
    Case 1:      Hunds = Hund
    Case 2:      Hunds = Mid(Hund, 1, 3) + Mid(Female(2), 4, 3)
    Case 3 To 9: Hunds = Female(Num) + Hund
   End Select
End Function

Function Tenteen(Num As Byte, ETens()) As String
  Const een = "een"
  
  Num = Num Mod 10
  Select Case Num
    Case 3 To 9:
      Tenteen = Mid(ETens(Num), 1, Len(ETens(Num)) - 1) + een
  End Select
End Function

Function EHunds(Num As Byte, ESingle()) As String
  EHunds = ESingle(Num) + " hundred"
End Function

Function ReFormat(InNum As Double, Dec As Byte) As Double
  Dim NewFormat As String
  
  If Dec > 0 Then NewFormat = "0." Else NewFormat = "0"
  NewFormat = NewFormat & String(Dec, "0")
  ReFormat = Format(InNum, NewFormat)
End Function

Function ReStr(InNum As String) As String
  Dim K, Digits As Byte
  Dim Num_ As String
  
  Num_ = LTrim(InNum)
  K = InStr(1, Num_, "E+", 1)
  If K > 0 Then
    Digits = Val(Mid(Num_, K + 2, 3))
    Num_ = Left(Num_, K - 1)
    Num_ = Delete(Num_, 2, 1)
    Do While Len(Num_) - 1 < Digits
      Num_ = Insert(Num_, "0", 1)
    Loop
  End If
  ReStr = Num_
End Function

Function AOnly(Num_, FracS, Single_, Ploral_ As String, Parts, Sex, Dec As Byte) As String
  Const And_ As String * 1 = "æ"
  Const Lang = vArabic
  Dim PartNum(0 To 5) As Long
  Dim Result1(0 To 5) As String
  Dim N1, N2, N3, TempI, Sex2, K As Byte
  Dim Only_    As String
  Dim OnlyPart As String
  Dim N1_, N2_ As String
  Dim N3_      As String
  Dim Part_    As String
  Dim TempS    As String
  Dim Sngl_1, Sngl_2 As String
  Dim Female(1 To 10) As Variant
  Dim Parts_(0 To 11) As String
    
  If Val(Num_) = 0 Then
    If FracS = "" Then
      AOnly = RTrim("ÕÝÑ " & Single_)
    Else
      AOnly = FracS & " " & Single_
    End If
    Exit Function
  End If
  
  Female(1) = "æÇÍÏÉ"
  Female(2) = "ÇËäÊÇä"
  Female(3) = "ËáÇË"
  Female(4) = "ÃÑÈÚ"
  Female(5) = "ÎãÓ"
  Female(6) = "ÓÊ"
  Female(7) = "ÓÈÚ"
  Female(8) = "ËãÇä"
  Female(9) = "ÊÓÚ"
  Female(10) = "ÚÔÑ"
   
  Parts_(0) = ""
  Parts_(1) = "ÃáÝ"
  Parts_(2) = "ãáíæä"
  Parts_(3) = "ãáíÇÑ"
  Parts_(4) = "ÊÑáíæä"
  Parts_(5) = "ßÏÑáíæä"
  Parts_(6) = ""
  Parts_(7) = "ÂáÇÝ"
  Parts_(8) = "ãáÇííä"
  Parts_(9) = "ãáíÇÑÇÊ"
  Parts_(10) = "ÊÑáíæäÇÊ"
  Parts_(11) = "ßÏÑáíæäÇÊ"
  
  K = InStr(1, Single_ & " ", " ")
  Sngl_1 = Left(Single_, K - 1)
  Sngl_2 = ""
  If K < Len(Single_) Then
    Sngl_2 = Mid(Single_, K + 1, Len(Single_))
  End If
  
  For K = 0 To Parts - 1
    PartNum(K) = Val(Mid(Num_, (K * 3) + 1, 3))
  Next K
    
    Sex2 = Sex
    For K = 0 To (Parts - 1)
      If K = (Parts - 1) Then Sex = Sex2 Else Sex = vMale
      TempS = Mid(Num_, (K * 3) + 1, 3)
      TempI = Val(Mid(TempS, 2, 2))
      N1 = Val(Mid(TempS, 1, 1))
      N2 = Val(Mid(TempS, 2, 1))
      N3 = Val(Mid(TempS, 3, 1))
      '{------------------------------------------}
      N1_ = "": N2_ = "": N3_ = ""
      If N1 > 0 Then N1_ = Hunds(CByte(N1), Female())
      If PartNum(K) = 200 Then N1_ = Mid(N1_, 1, Len(N1_) - 1)
      Select Case TempI
        Case 1 To 2:
          If K = Parts - 1 Then If FracS <> "" Then N3_ = Fmale(N3, CByte(Sex), Female())  'Sex
        Case 3 To 19:
          N3_ = Fmale(TempI, CByte(Sex), Female())
        Case 20 To 99:
          N2_ = Tens(CByte(N2), Female())
          If N3 > 0 Then N3_ = Fmale(N3, CByte(Sex), Female())
          If (N3 Mod 10 = 1) And (Sex = vFemale) Then N3_ = "ÅÍÏì"
      End Select
      OnlyPart = AddAnd(N1_, N3_, N2_, And_, Lang)
      '{------------------------------------------}
      If PartNum(K) > 100 Then
        Select Case TempI
          Case 1, 2:
            OnlyPart = AddAnd(OnlyPart, Parts_(Parts - K - 1), "", "", Lang)
        End Select
      End If
      '{------------------------------------------}
      Part_ = ""
      If PartNum(K) > 0 Then
        Part_ = Parts_(Parts - K - 1)
        If Part_ <> "" Then
          Select Case TempI
            Case 2:        Part_ = Part_ + "Çä"
            Case 3 To 10:  Part_ = Parts_((Parts - K - 1) + 6)
            Case 11 To 99: Part_ = Part_ + "Ç"
          End Select
        End If
      End If
      '{------------------------------------------}
      If Part_ <> "" Then
        If TempI >= 1 And TempI <= 2 Then
           OnlyPart = AddAnd(OnlyPart, Part_, "", And_, Lang)
        Else
          OnlyPart = AddAnd(OnlyPart, Part_, "", "", Lang)
        End If
      End If
      Result1(K) = (OnlyPart)
    Next K
    '{------------------------------------------}
    N1_ = AddAnd(Result1(0), Result1(1), Result1(2), And_, Lang)
    N2_ = AddAnd(Result1(3), Result1(4), Result1(5), And_, Lang)
    Only_ = AddAnd(N1_, N2_, "", And_, Lang)

    If FracS <> "" Then
      If Only_ <> "" Then FracS = " " + FracS
      Only_ = AddAnd(Only_, FracS, "", And_, Lang)
    End If
    If Only_ <> "" Then
      If Mid(Only_, Len(Only_), 1) = "Ç" Then
        If Mid(Only_, Len(Only_) - 1, 2) <> "ÊÇ" Then
          Only_ = Mid(Only_, 1, Len(Only_) - 1)
        End If
      End If
      If TempS = "000" Then
        If Mid(Only_, Len(Only_) - 1, 2) = "Çä" Then
          Only_ = Mid(Only_, 1, Len(Only_) - 1)
        End If
      End If
    End If
    '{------------------------------------------}
    If FracS = "" Then
      Select Case TempI
        Case 0: If Only_ <> "" Then Only_ = AddAnd(Only_, Single_, "", "", Lang)
        Case 1: Only_ = AddAnd(Only_, AddAnd(Single_, Fmale(1, CByte(Sex), Female()), "", "", Lang), "", And_, Lang)
        Case 2: Only_ = AddAnd(Only_, AddAnd(S2Double(Single_, CByte(Sex)), Fmale(2, CByte(Sex), Female()), "", "", Lang), "", And_, Lang)
        Case 3 To 10:
          If Sngl_2 <> "" Then
            If Right(Sngl_2, 1) = "É" Then
              Only_ = AddAnd(Only_, Ploral_, Sngl_2, "", Lang)
            Else
              Only_ = AddAnd(Only_, Ploral_, Sngl_2 & "É", "", Lang)
            End If
          Else
            Only_ = AddAnd(Only_, Ploral_, "", "", Lang)
          End If
        Case 11 To 99:
          If Sngl_1 <> "" Then
            Only_ = AddAnd(Only_, Sngl_1, "", "", Lang)
            N1_ = Mid(Only_, Len(Only_), 1)
            Select Case N1_
              Case "É", "ì", "Ç"
              Case Else
                Only_ = Only_ + "Ç"
            End Select
            N1_ = Mid(Only_, Len(Only_) - 2, 3)
            'åÐÇ ÇáÔÑØ áÍá ãÔßáÉ ÚÏã ÇáÊãííÒ Èíä "Á" æ "á" 2002/08/24
            If N1_ = "ÇÁÇ" And Asc(Right(Sngl_1, 1)) = 193 Then
              Only_ = Left(Only_, Len(Only_) - 1)
            End If
            If Sngl_2 <> "" Then
              If Right(Only_, 1) = "Ç" Then
                Only_ = AddAnd(Only_, Sngl_2 & "Ç", "", "", Lang)
              Else
                Only_ = AddAnd(Only_, Sngl_2, "", "", Lang)
              End If
            Else
              Only_ = AddAnd(Only_, Sngl_2, "", "", Lang)
            End If
          End If
      End Select
    Else
      Only_ = AddAnd(Only_, Sngl_1, Sngl_2, "", Lang)
    End If
    AOnly = (Only_)
End Function

Function EOnly(Num_, FracS, Single_ As String, Parts, Dec As Byte) As String
  Const Lang = vEnglish
  Dim ESingle(1 To 12) As Variant
  Dim ETens(2 To 9) As Variant
  Dim EParts_(0 To 5) As String
  Dim TempS As String
  Dim N1, N2, N3, TempI, Sex2 As Byte
  Dim N1_, N2_, N3_ As String
  Dim OnlyPart, Part_, Only_ As String
  Dim Leng, K As Integer
  Dim PartNum(0 To 5) As Long
  Dim Result1(0 To 5) As String
  
  If Val(Num_) = 0 Then
    If FracS = "" Then
      EOnly = LTrim(Single_ & " zero")
    Else
      EOnly = Single_ & " " & FracS
    End If
    Exit Function
  End If
  
  ESingle(1) = "one"
  ESingle(2) = "two"
  ESingle(3) = "three"
  ESingle(4) = "four"
  ESingle(5) = "five"
  ESingle(6) = "six"
  ESingle(7) = "seven"
  ESingle(8) = "eight"
  ESingle(9) = "nine"
  ESingle(10) = "ten"
  ESingle(11) = "eleven"
  ESingle(12) = "twelve"
  
  ETens(2) = "twenty"
  ETens(3) = "thirty"
  ETens(4) = "forty"
  ETens(5) = "fifty"
  ETens(6) = "sixty"
  ETens(7) = "seventy"
  ETens(8) = "eighty"
  ETens(9) = "ninety"
  
  EParts_(0) = ""
  EParts_(1) = "thousund"
  EParts_(2) = "million"
  EParts_(3) = "billion"
  EParts_(4) = "trillion"
  EParts_(5) = "quadrillion"
  
  For K = 0 To Parts - 1
    PartNum(K) = Val(Mid(Num_, (K * 3) + 1, 3))
  Next K
  
  For K = 0 To (Parts - 1)
    TempS = Mid(Num_, (K * 3) + 1, 3)
    TempI = Val(Mid(TempS, 2, 2))
    N1 = Val(Mid(TempS, 1, 1))
    N2 = Val(Mid(TempS, 2, 1))
    N3 = Val(Mid(TempS, 3, 1))
    '{------------------------------------------}
    N1_ = "": N2_ = "": N3_ = ""
    If N1 > 0 Then N1_ = EHunds(CByte(N1), ESingle())
    Select Case TempI
      Case 1 To 12:  N3_ = ESingle(TempI)
      Case 13 To 19: If N3 > 0 Then N3_ = Tenteen(CByte(TempI), ETens())
      Case 20 To 99:
        N2_ = ETens(N2)
        If N3 > 0 Then
          N3_ = N2_ + "-" + ESingle(N3)
          N2_ = ""
        End If
    End Select
    OnlyPart = AddAnd(N1_, N2_, N3_, "", Lang)
    '{------------------------------------------}
    Part_ = ""
    If PartNum(K) > 0 Then
      Part_ = EParts_(Parts - K - 1)
      If Part_ <> "" Then Part_ = EParts_((Parts - K - 1))
    End If
    Result1(K) = AddAnd(OnlyPart, Part_, "", "", Lang)
  Next K
  '{------------------------------------------}
  N1_ = AddAnd(Result1(0), Result1(1), Result1(2), "", Lang)
  N2_ = AddAnd(Result1(3), Result1(4), Result1(5), "", Lang)
  Only_ = AddAnd(N1_, N2_, "", "", Lang)

  Leng = Len(Only_)
  Only_ = AddAnd(Only_, FracS, "", " and", Lang)
  If Only_ <> "" Then
    Only_ = AddAnd(Single_, Only_, "", "", Lang)
    EOnly = Only_
  End If
End Function

Function S_Only(InNum As Variant, Lang, FracType As Byte) As Variant
  Dim Num_ As String
  Dim K, Dec As Byte
  Dim FType As Byte
  
  If IsNull(InNum) Then
    S_Only = Null
    Exit Function
  End If
  
  Num_ = Str(InNum)
  K = InStr(1, Num_, ".", 1)
  If K > 0 Then
    Dec = Len(Num_) - K
    If Dec < 2 Then Dec = 2
  Else
   Dec = 0
  End If
  
  FType = FracType
  If FType <> 2 Then FType = 1
  
  S_Only = B_Only(InNum, Lang, 0, Dec, "", "", 0, "", "", FType)
End Function
  
Function B_Only(InNum As Variant, Lang, Sex, Dec As Byte, Single_, Ploral_ As String, _
                FSex As Byte, SFrac, PFrac As String, FracType As Byte) As Variant
  Dim Leng, Parts, K As Byte
  Dim FracVal  As Double
  Dim Num_     As String
  Dim FracS    As String
  Dim FracNum  As String
  Dim Only     As String
  
  If IsNull(InNum) Then
    B_Only = Null
    Exit Function
  End If
  
  Num_ = Str(InNum)
  If InStr(1, Num_, "E+", 1) > 0 Then
    Num_ = ReStr(Num_)
    FracVal = 0
    GoTo DoProcess
  End If
  
  Num_ = ReFormat(Val(InNum), Dec)
  K = InStr(1, Num_, ".", 1)
  If K > 0 Then FracS = "0" & Mid(Num_, K, Dec + 1) Else FracS = ""
  FracVal = Val(FracS)
  Num_ = Trim(Str(Fix(InNum)))
  
  Do While Len(FracS) < Dec + 2
    FracS = Insert(FracS, "0", 1)
  Loop

DoProcess:
  If FracVal = 0 Then FracS = ""
  FracNum = Trim(Mid(FracS, 3, Len(FracS)))
  If FracS <> "" Then
    Select Case FracType
      Case 2
        Select Case Lang
          Case vArabic:  FracS = "1" & String(Dec, "0") & "/" & Format(FracNum, String(Dec, "0"))
          Case vEnglish: FracS = Format(FracNum, String(Dec, "0")) & "/" & "1" & String(Dec, "0")
        End Select
      Case 3
        FracS = FracNum & " " & SFrac
        If Lang = vEnglish And CDbl(FracNum) > 1 Then FracS = FracS & "'s"
      Case 4
        Leng = Len(FracNum)
        Parts = Fix((Leng + 2) / 3)
        For K = 1 To (Parts * 3) - Leng
          FracNum = Insert("0", FracNum, 1)
        Next K
        Select Case Lang
          Case vArabic:  FracS = AOnly(FracNum, "", SFrac, PFrac, Parts, FSex, FracType)
          Case vEnglish: FracS = EOnly(FracNum, "", "", Parts, 0) & " " & SFrac
                         If CDbl(FracNum) > 1 Then FracS = FracS & "'s"
        End Select
    End Select
  End If
  
  Leng = Len(Num_)
  Parts = Fix((Leng + 2) / 3)
  
  For K = 1 To (Parts * 3) - Leng
    Num_ = Insert("0", Num_, 1)
  Next K
  
  If Len(Num_) > 18 Then
    B_Only = InNum
    Exit Function
  End If
 
  Select Case FracType
    Case 1, 2
      Select Case Lang
        Case vArabic:  Only = AOnly(Num_, FracS, Single_, Ploral_, Parts, Sex, Dec)
        Case vEnglish: Only = EOnly(Num_, FracS, Single_ & "", Parts, Dec)
      End Select
    Case 3, 4
      Select Case Lang
        Case vArabic:  Only = AOnly(Num_, "", Single_, Ploral_, Parts, Sex, Dec)
                       If CDbl(Num_) = 0 And FracS <> "" Then Only = ""
                       If FracS <> "" Then Only = AddAnd(Only, FracS, "", "æ ", CByte(Lang))
        Case vEnglish: Only = EOnly(Num_, "", Single_ & "", Parts, Dec)
                       If CDbl(Num_) = 0 And FracS <> "" Then Only = ""
                       If FracS <> "" Then Only = AddAnd(Only, FracS, "", " and", CByte(Lang))
      End Select
  End Select
  
  If Only <> "" Then
    Select Case Lang
      Case vArabic:  B_Only = "ÝÞØ " & Only
      Case vEnglish: B_Only = Only & " only"
    End Select
  End If
End Function

وعليك بوضع هذه المعادلة فى الخلية التى تريد اظهار التفقيط بها

بمعنى لو افترضنا ان الرقم موجود بالخلية A2 تكون المعادلة كالتالى :

=B_Only(A2,1,0,2,"ريال ","ريالات",0,"فلس","فلسات",4)

 

 

[ISAMD1972]

كود التفقيط موجود داخل modules  عن طريق الضغط على اسم الورقة اسقل الشيت واختيار عرض التعليمات البرمجية

بالتوفيق

التفقيط.xls