15- كود التفقيط باللغة الانجليزية لاى خلية فى الاكسل مع تثبيت الكود كإيقونة فى كل شيتات الاكسل .

[@QuantitiesSurveying]

Sub ConvertNumberToTextEnglish()
Dim sourceCell As Range
Dim targetCell As Range
Dim numberToConvert As Variant
Dim resultText As String
Dim MainCurrency As String
Dim SubCurrency As String
On Error Resume Next
Set sourceCell = Application.InputBox("يرجى اختيار الخلية التي تحتوي على الرقم:", Type:=8)
On Error GoTo 0
If sourceCell Is Nothing Then
MsgBox "لم يتم اختيار أي خلية. تم إلغاء العملية."
Exit Sub
End If
' الحصول على الرقم
numberToConvert = sourceCell.Value
If Not IsNumeric(numberToConvert) Then
MsgBox "الخلية المختارة لا تحتوي على رقم صالح."
Exit Sub
End If
On Error Resume Next
Set targetCell = Application.InputBox("يرجى اختيار الخلية التي سيتم كتابة النص فيها:", Type:=8)
On Error GoTo 0
If targetCell Is Nothing Then
MsgBox "لم يتم اختيار أي خلية. تم إلغاء العملية."
Exit Sub
End If
MainCurrency = "Riyals"
SubCurrency = "Halalas"
resultText = "Only " & NumberToTextEN(CStr(numberToConvert), MainCurrency, SubCurrency)
targetCell.Value = resultText
' MsgBox "تم تحويل الرقم إلى نص وكتابته في الخلية المختارة."
End Sub
Function NumberToTextEN(ByVal MyNumber As String, MainCurrency As String, SubCurrency As String) As String
Dim Number1, Number2, Temp As String
Dim DecimalPlace, Count As Integer
Dim Place(9) As String

Place(2) = " Thousand "
Place(3) = " Million "
Place(4) = " Billion "
Place(5) = " Trillion "

MyNumber = Trim(Str(MyNumber))
DecimalPlace = InStr(MyNumber, ".")

If DecimalPlace > 0 Then
Number2 = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2))
MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
End If

Count = 1

Do While MyNumber ""
Temp = GetHundreds(Right(MyNumber, 3))
If Temp "" Then Number1 = Temp & Place(Count) & Number1
If Len(MyNumber) > 3 Then
MyNumber = Left(MyNumber, Len(MyNumber) - 3)
Else
MyNumber = ""
End If
Count = Count + 1
Loop

Select Case Number1
Case ""
Number1 = "No " & MainCurrency
Case Else
Number1 = Number1 & " " & MainCurrency
End Select

Select Case Number2
Case ""
Number2 = ""
Case Else
Number2 = " and " & Number2 & " " & SubCurrency
End Select

NumberToTextEN = Number1 & Number2
End Function
Function GetHundreds(ByVal MyNumber As String) As String
Dim Result As String
If Val(MyNumber) = 0 Then Exit Function
MyNumber = Right("000" & MyNumber, 3)

If Mid(MyNumber, 1, 1) "0" Then
Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
End If

If Mid(MyNumber, 2, 1) "0" Then
Result = Result & GetTens(Mid(MyNumber, 2))
Else
Result = Result & GetDigit(Mid(MyNumber, 3))
End If

GetHundreds = Result
End Function
Function GetTens(ByVal TensText As String) As String
Dim Result As String
Result = ""

If Val(Left(TensText, 1)) = 1 Then
Select Case Val(TensText)
Case 10: Result = "Ten"
Case 11: Result = "Eleven"
Case 12: Result = "Twelve"
Case 13: Result = "Thirteen"
Case 14: Result = "Fourteen"
Case 15: Result = "Fifteen"
Case 16: Result = "Sixteen"
Case 17: Result = "Seventeen"
Case 18: Result = "Eighteen"
Case 19: Result = "Nineteen"
End Select
Else
Select Case Val(Left(TensText, 1))
Case 2: Result = "Twenty "
Case 3: Result = "Thirty "
Case 4: Result = "Forty "
Case 5: Result = "Fifty "
Case 6: Result = "Sixty "
Case 7: Result = "Seventy "
Case 8: Result = "Eighty "
Case 9: Result = "Ninety "
End Select
Result = Result & GetDigit(Right(TensText, 1))
End If

GetTens = Result
End Function
Function GetDigit(ByVal Digit As String) As String
Select Case Val(Digit)
Case 1: GetDigit = "One"
Case 2: GetDigit = "Two"
Case 3: GetDigit = "Three"
Case 4: GetDigit = "Four"
Case 5: GetDigit = "Five"
Case 6: GetDigit = "Six"
Case 7: GetDigit = "Seven"
Case 8: GetDigit = "Eight"
Case 9: GetDigit = "Nine"
Case Else: GetDigit = ""
End Select
End Function