اضافة كلمة الى كود التفقيط اكسل.

[sideeq]

ارجو ممن لديه خبرة من الاخوة خبراء الاكسل الاعزاء

اضافة كلمة (درجة) بعد الرقم و (جزء من الدرجة) بعد الكسر العشري . الى كود التفقيط التالي  . ونفسه مرفق في الملف باسم كود ابو حمود 

Public Ones(0 To 12) As String
Public Twos(2 To 9) As String
Public Threes(1 To 2) As String
Public Fours(1 To 3) As String
Public Sevens(1 To 3) As String
Public Tens(1 To 2) As String
Public Prepositions() As String
Public Decimals(1 To 3) As String

Public Function Main(الرقم_رقماً)
Dim lRange As Long
Dim lPosDecimal As Long
Dim sWhole As String, sDecimal As String

On Error Resume Next

LoadArrays
'الرقم_رقماً = Forms![نموذج1]![نص84]
lRange = Len(الرقم_رقماً)

If lRange <> 0 Then
lPosDecimal = InStr(1, الرقم_رقماً, ".", vbTextCompare)
If lPosDecimal > 0 Then
sWhole = Mid(الرقم_رقماً, 1, lPosDecimal - 1)
sDecimal = Mid(الرقم_رقماً, lPosDecimal + 1)

sWhole = sLeftRemove(sWhole, "0")
sDecimal = sRightRemove(sDecimal, "0")

If InStr(sDecimal, ".") Then sDecimal = sFindReplace(sDecimal, ".", "")
If InStr(sWhole, ",") Then sWhole = sFindReplace(sWhole, ",", "")
If InStr(sWhole, "،") Then sWhole = sFindReplace(sWhole, "،", "")
If InStr(sDecimal, ",") Then sWhole = sFindReplace(sDecimal, ",", "")
If InStr(sDecimal, "،") Then sWhole = sFindReplace(sDecimal, "،", "")

If Len(sDecimal) > 9 And Len(sWhole) > 9 Then
MsgBox "Sorry:This addin does not support more than 9 digits for " & _
"whole and decimal portion of the number", vbOKOnly, "Number to Text"
Exit Function
End If
If Len(sWhole) > 9 Then
MsgBox "Sorry:This addin does not support more than 9 digits for " & _
"whole portion of the number", vbOKOnly, "Number to Text"
Exit Function
End If
If Len(sDecimal) > 9 Then
MsgBox "Sorry:This addin does not support more than 9 digits for " & _
"decimal portion of the number", vbOKOnly, "Number to Text"
Exit Function
End If

If sDecimal <> "" Then
If CLng(sDecimal) <> 0 Then
If sWhole <> "" Then
If CLng(sWhole) <> 0 Then
الرقم_كتابة = sNum2Text(CLng(sWhole)) & " " & Prepositions(1) & _
sDec2Text(sDecimal)
Else
الرقم_كتابة = sDec2Text(sDecimal)
End If
Else
الرقم_كتابة = sDec2Text(sDecimal)
End If
Else
الرقم_كتابة = sNum2Text(CLng(sWhole))
End If
Else
الرقم_كتابة = sNum2Text(CLng(sWhole))
End If

Else 'Only whole number
If InStr(sWhole, ",") Then sWhole = sFindReplace(sWhole, ",", "")
If InStr(sWhole, "،") Then sWhole = sFindReplace(sWhole, "،", "")
sWhole = الرقم_رقماً
sWhole = sLeftRemove(sWhole, "0")

If Len(sWhole) > 9 Then
MsgBox "Sorry:This addin does not support more than 9 digits for " & _
"whole portion of the number", vbOKOnly, "Number to Text"
Exit Function
End If

الرقم_كتابة = sNum2Text(CLng(sWhole))
End If
End If
' MsgBox الرقم_كتابة
Main = الرقم_كتابة
End Function

Public Function sNum2Text(lNum As Long) As String
Dim sNum As String 'The number as string to pass as a vlaue name in the INI file
Dim I As Integer 'Loop counter to loop through all of the digits
Dim iUpperBound As Integer 'Represents # of digits in each group of 3 significant bits

On Error Resume Next

sNum = Trim$(CStr(lNum))
'Get rid of the zeros to the left

If (lNum >= 0) And (lNum <= 12) Then '0 through 12
sNum2Text = Ones(lNum)
ElseIf lNum Mod 10 = 0 And Len(sNum) = 2 Then '20,30,40,...,90
sNum2Text = Twos(CLng(Left(sNum, 1)))
ElseIf lNum > 12 And lNum < 20 Then '13 to 19
sNum2Text = Ones(CLng(Right(sNum, 1))) & " " & Ones(10)
ElseIf lNum Mod 10 > 0 And Len(sNum) = 2 Then '21,22,...29,31,32,33,...,99
sNum2Text = Ones(CLng(Right(sNum, 1))) & " " & Prepositions(1) & _
Twos(CLng(Left(sNum, 1)))
ElseIf (lNum = 100) Or (lNum = 200) Then '100,200
sNum2Text = Threes(CLng(Left(sNum, 1)))
ElseIf (lNum Mod 100) = 0 And Len(sNum) = 3 Then '300,400,500,...,900
sNum2Text = Ones(CLng(Left(sNum, 1))) & " " & Threes(1)
ElseIf lNum Mod 100 > 0 And Len(sNum) = 3 Then '101,102,103,...,199,201,...999
If Left(sNum, 1) <> "1" And Left(sNum, 1) <> "2" Then
sNum2Text = Ones(CLng(Left(sNum, 1))) & " " & Threes(1)
Else
sNum2Text = Threes(CLng(Left(sNum, 1)))
End If
If Right(sNum, 2) = "11" Or Right(sNum, 2) = "12" Then
sNum2Text = sNum2Text & " " & Prepositions(1) & Ones(CLng(Right(sNum, 2)))
ElseIf Mid(sNum, 2, 1) <> "0" And Mid(sNum, 2, 1) <> "1" And Right(sNum, 1) <> 0 Then
sNum2Text = sNum2Text & " " & Prepositions(1) & Ones(CLng(Right(sNum, 1))) & _
" " & Prepositions(1) & Twos(CLng(Mid(sNum, 2, 1)))
ElseIf Mid(sNum, 2, 1) <> "0" And Mid(sNum, 2, 1) <> "1" And Right(sNum, 1) = 0 Then
sNum2Text = sNum2Text & " " & Prepositions(1) & Twos(CLng(Mid(sNum, 2, 1)))
ElseIf Mid(sNum, 2, 1) = "1" Then
sNum2Text = sNum2Text & " " & Prepositions(1) & Ones(CLng(Right(sNum, 1))) & _
" " & Ones(10)
ElseIf Mid(sNum, 2, 1) = "0" Then
sNum2Text = sNum2Text & " " & Prepositions(1) & Ones(CLng(Right(sNum, 1)))
Else 'Right(sNum, 2) = "00"
sNum2Text = sNum2Text
End If

ElseIf Len(sNum) / 3 > 1 Then
Do Until Len(sNum) = 3
If Len(sNum) Mod 3 <> 0 Then
iUpperBound = Len(sNum) Mod 3
Else
iUpperBound = 3
End If
If (Len(sNum) / 3 > 2) And (Len(sNum) / 3 < 4) Then
'In the millions
If Mid(sNum, 1, iUpperBound) = "000" Then
Exit Do
ElseIf (Len(sNum) Mod 3 = 1) And (Left(sNum, 1) = "1" Or Left(sNum, 1) = "2") Then
sNum2Text = sNum2Text & Sevens(CLng(Left(sNum, 1))) & " " & Prepositions(1)
ElseIf (Len(sNum) Mod 3 = 1) And Left(sNum, 1) <> "1" And Left(sNum, 1) <> "2" Then
sNum2Text = sNum2Text & sNum2Text(CLng(Mid(sNum, 1, iUpperBound))) & _
" " & Sevens(3) & " " & Prepositions(1)
ElseIf (Len(sNum) Mod 3 = 2) And Left(sNum, 2) = "10" Then
sNum2Text = sNum2Text & sNum2Text(CLng(Mid(sNum, 1, iUpperBound))) & _
" " & Sevens(3) & " " & Prepositions(1)
Else
sNum2Text = sNum2Text & sNum2Text(CLng(Mid(sNum, 1, iUpperBound))) & _
" " & Sevens(1) & " " & Prepositions(1)
End If
ElseIf (Len(sNum) / 3 >= 1) And (Len(sNum) / 3 < 3) Then
'In the thousands
If Mid(sNum, 1, iUpperBound) = "000" Then
Exit Do
ElseIf (Len(sNum) Mod 3 = 1) And (Left(sNum, 1) = "1" Or Left(sNum, 1) = "2") Then
sNum2Text = sNum2Text & Fours(CLng(Left(sNum, 1))) & " " & Prepositions(1)
ElseIf (Len(sNum) Mod 3 = 1) And Left(sNum, 1) <> "1" And Left(sNum, 1) <> "2" Then
sNum2Text = sNum2Text & sNum2Text(CLng(Mid(sNum, 1, iUpperBound))) & _
" " & Fours(3) & " " & Prepositions(1)
ElseIf (Len(sNum) Mod 3 = 2) And Left(sNum, 2) = "10" Then
sNum2Text = sNum2Text & sNum2Text(CLng(Mid(sNum, 1, iUpperBound))) & _
" " & Fours(3) & " " & Prepositions(1)
Else
sNum2Text = sNum2Text & sNum2Text(CLng(Mid(sNum, 1, iUpperBound))) & _
" " & Fours(1) & " " & Prepositions(1)
End If
End If
sNum = Mid(sNum, iUpperBound + 1)
lNum = CLng(sNum)
'Make sure the least significant 6 digits are not zero

If sNum = String(Len(sNum), "0") Then
sNum2Text = Left(sNum2Text, Len(sNum2Text) - 1)
Exit Function
End If
Loop

'Make sure the least significant 3 digits are not zero
If sNum <> String(Len(sNum), "0") Then
sNum2Text = sNum2Text & sNum2Text(lNum)
Else 'get ride of the AND
sNum2Text = Left(sNum2Text, Len(sNum2Text) - 1)
End If
End If

End Function

Public Function sDec2Text(sNum As String) As String

Dim lLen As Long
On Error Resume Next

Do While Right(sNum, 1) = "0"
sNum = Left(sNum, Len(Trim(sNum)) - 1)
Loop

lLen = Len(Trim(sNum))

If lLen = 0 Then
sDec2Text = ""
Exit Function
ElseIf lLen = 1 Then
Select Case sNum
Case "0"
sDec2Text = ""
Case "1"
sDec2Text = Decimals(1)
Case "2"
sDec2Text = Decimals(2)
Case Else
sDec2Text = sNum2Text(CLng(Trim(sNum))) & " " & Decimals(3)
End Select
ElseIf lLen = 2 Then
sDec2Text = sNum2Text(CLng(Trim(sNum))) & " " & Prepositions(2) & _
sNum2Text("1" & String(lLen, "0"))
ElseIf lLen = 9 Then
sDec2Text = sNum2Text(CLng(Trim(sNum))) & " " & Prepositions(3) & _
Tens(1)
Else
sDec2Text = sNum2Text(CLng(Trim(sNum))) & " " & Prepositions(3) & _
sNum2Text("1" & String(lLen, "0"))
End If

End Function

Public Sub LoadArrays()

'Load the arrays with values

'Ones
Ones(0) = "صفر"
Ones(1) = "واحد"
Ones(2) = "اثنان"
Ones(3) = "ثلاثة"
Ones(4) = "أربعة"
Ones(5) = "خمسة"
Ones(6) = "ستة"
Ones(7) = "سبعة"
Ones(8) = "ثمانية"
Ones(9) = "تسعة"
Ones(10) = "عشرة"
Ones(11) = "أحد عشرة"
Ones(12) = "اثنا عشرة"

'Twos
Twos(2) = "عشرون"
Twos(3) = "ثلاثون"
Twos(4) = "أربعون"
Twos(5) = "خمسون"
Twos(6) = "ستون"
Twos(7) = "سبعون"
Twos(8) = "ثمانون"
Twos(9) = "تسعون"

'Threes
Threes(1) = "مائة"
Threes(2) = "مائتان"

'Fours
Fours(1) = "ألف"
Fours(2) = "ألفان"
Fours(3) = "آلاف"

'Sevens
Sevens(1) = "مليون"
Sevens(2) = "مليونان"
Sevens(3) = "ملايين"

'Tens
Tens(1) = "بليون"
Tens(2) = "بلايين"

'Prepositions
ReDim Prepositions(1 To 3)
Prepositions(1) = "و"
Prepositions(2) = "بال"
Prepositions(3) = "من ال"

'Decimals
Decimals(1) = "عشر"
Decimals(2) = "عشران"
Decimals(3) = "أعشار"

End Sub

Public Function sFindReplace(sString As String, sOld As String, sNew As String) As String
On Error GoTo sFindReplace_Hndlr
Dim I As Integer
sFindReplace = sString
I = 1
'Loop through all the characters of a string
For j = 1 To Len(sString)
If InStr(sOld, Mid(sFindReplace, I, 1)) Then
sFindReplace = Mid(sFindReplace, 1, I - 1) & sNew & Mid(sFindReplace, I + 1)
I = I - 1
End If
I = I + 1
Next j
Exit Function
sFindReplace_Hndlr:
Debug.Print "RTE Desc: " & Err.Description
Debug.Print "RTE Num: " & Err.Number
sFindReplace = sString
Exit Function
End Function

Public Function sLeftRemove(str1 As String, str2 As String) As String
On Error Resume Next
If str1 = "0" And str2 = "0" Then
sLeftRemove = str1
Exit Function
End If
Do While Left(str1, 1) = str2
str1 = Mid(str1, 2)
Loop
If str1 = "" Then str1 = "0"
sLeftRemove = str1
End Function

Public Function sRightRemove(str1 As String, str2 As String) As String
On Error Resume Next
If str1 = "0" And str2 = "0" Then
sRightRemove = str1
Exit Function
End If
Do While Right(str1, 1) = str2
str1 = Mid(str1, 1, Len(str1) - 1)
Loop
If str1 = "" Then str1 = "0"
sRightRemove = str1
End Function

'وفي النموذج في حدث عند الخروج من حقل الرقم ضع :
'Private Sub حقل_الرقم_Exit(Cancel As Integer)
'If Not IsNull(Me!حقل_الرقم) Then
'الرقم_رقما 'ً = حقل_الرقم
'Call Main '
'[حقل'_الكتابة] = الرقم_كتابة
'End If
'End Sub

 

 

كود ابو حمود.docx

تم تعديل يونيو 8, 2018 بواسطه sideeq

[طلعت محمد حسن]

السلام عليكم

اخي الكريم هل تقصد هكذا كما بالمرفق.

التفقيط درجات.xlsm

[sideeq]

اشكر ردك اخي العزيز طلعت وبوركت .

لكن انا اريد الدالة تظهر الرفم العشري مثلا تقرأ 5.012  خمسة درجة واثنا عشر بالالف جزء من الدرجة . والتي ذكرتها لا تقرأ بهذا الشكل 

والتي عندي تقرا بهذا الشكل لكن ليس فيها كلمة درجة وجزء من الدرجة ، فهل تستطيع اظافتها واكون شاكرا لك

مع تحياتي

تم تعديل يونيو 9, 2018 بواسطه sideeq

[عبدللرحيم]

تفضل يا أخى

التفقيط درجات.xlsm

[sideeq]

اشكرك اخي عبد الرحيم 

لكن هذه الدالة تقرا الارقام العشرية بشكل خاطي 

فمثلا تقرا الرقم 6.022 ستة درجات واثنان وعشرون جزء من الدرجة في حين ان الصحيح هو ست درجات واثنان وعشرون جزء بالالف من الدرجة

اي يجب ان يذكر جزء بالمئ او جزء بالالف او جزء بالعشرة الاف 

فعندي هذه الكود الذي ارفقته يقرا الاجزاء العشرية بشكل جيد جدا واسمه ابوحمود . لكن اريد ان اضيف له كلمة درجة وجزء من الدرجة 

[الحضرمي2017]

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

[الحضرمي2017]

لو تكرم احد الاخوة في شرح كيفية اضافة مثل هذا الكود الى الاكسل

[sideeq]

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

كود ابو حمود 1.xlsm