اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

كيف اضيف هذا الكود في الاكسل وماهي الصيغة التي اكتبها في الخلية

الحضرمي2017

بواسطه الحضرمي2017
في منتدى الاكسيل Excel

 مشاركة

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

الحضرمي2017

الحضرمي2017

قام بنشر
قام بنشر

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

حياكم الله اخوتي الاحبة اريد ان اعرف اين اضيف هذا الكود في الاكسل هل هو في موديل module جديد ام في ورقة العمل ام اين بالضبط ثم بعد الاضافة ماهي الصيغة التي اضيفها في الخلية

واذا تكرم احد الاخوة وجهز الملف بالكود اكون شاكر له وجزاه الله خير الجزاء الكود هو  

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

 

رابط هذا التعليق
شارك
  • 1 month later...

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

  I accept