الرئيسية
المزاج
افتح صفحة الاكسال واضغط على الخانة التي ترغب التحويل اليها
بعد ذلك توجه لقائمة ادوات واضغط على ماكرو ثم على محرر الفيزيال بازيك فتظهر لك صفحة جديدة فارغة للمحرر
ثم اختار usert userfrom هي بالقرب من مفتاح الحفظ لليسار تماما فتظهر لك 03 خيارات اختارmodule فتظهر لك نافذة فارغة بيضاء قم بنسخ هذه الدالة ولصقها في الفراغ الدالة هي:
'NombreToArabe(Cellule)
'Conversion Automatique de Chiffre en Lettre Arabe
Function lireCentaine(ByVal Montant As Double) As String
Dim ChiffreLettre
Dim Centaine As Double
Dim Dizaine As Double
Dim T As String
Dim Chaine As String
ChiffreLettre = Array("واحد", "إثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة", "عشرة", "إحدى عشر", "إثنى عشر", "ثلاثة عشر", "أربعة عشر", "خمسة عشر", "ستة عشر", "سبعة عشر", "ثمانية عشر", "تسعة عشر")
Centaine = Int(Montant / 100)
Select Case Centaine
Case 0
Chaine = ""
Case 1
Chaine = "مائة"
Case 2
Chaine = "مائتان"
Case 3
Chaine = "ثلاثمائة"
Case 4
Chaine = "أربعمائة"
Case 5
Chaine = "خمسمائة"
Case 6
Chaine = "ستمائة"
Case 7
Chaine = "سبعمائة"
Case 8
Chaine = "ثمانمائة"
Case 9
Chaine = "تسعمائة"
End Select
Dizaine = Modulo(Montant, 100)
Select Case Dizaine
Case 0
T = ""
Case 1 To 19
T = ChiffreLettre(Dizaine - 1)
Case 20
T = " عشرون"
Case 21 To 29
T = ChiffreLettre(Dizaine - 21) & " و عشرون"
Case 30
T = " ثلاثون"
Case 31 To 39
T = ChiffreLettre(Dizaine - 31) & " و ثلاثون"
Case 40
T = " أربعون"
Case 41 To 49
T = ChiffreLettre(Dizaine - 41) & " و أربعون"
Case 50
T = " خمسون"
Case 51 To 59
T = ChiffreLettre(Dizaine - 51) & " و خمسون"
Case 60
T = " ستون"
Case 61 To 69
T = ChiffreLettre(Dizaine - 61) & " و ستون"
Case 70
T = " سبعون"
Case 71 To 79
T = ChiffreLettre(Dizaine - 71) & " و سبعون"
Case 80
T = " ثمانون"
Case 81 To 89
T = ChiffreLettre(Dizaine - 81) & " و ثمانون"
Case 90
T = " تسعون"
Case 90 To 99
T = ChiffreLettre(Dizaine - 91) & " و تسعون"
Case Else
T = "Erreur de conversion !"
End Select
If Chaine <> "" Then
If (T <> "") Then
Chaine = Chaine
T = " و " & T
End If
End If
If Chaine = "" Then
If (T <> "") Then
Chaine = Chaine
T = T
End If
End If
If (Chaine & " " & T) = " " Then
lireCentaine = ""
Else
lireCentaine = LTrim(Chaine & " ") & T
End If
End Function
Function Modulo(ByVal Nombre As Double, ByVal Diviseur As Double) As Double
Modulo = Nombre - (Diviseur * Int(Nombre / Diviseur))
End Function
Function Arrondir(ByVal ValeurArrondi As Double, ByVal NbreDeci As Integer) As Double
Arrondir = ValeurArrondi + (5 * 10 ^ -(NbreDeci + 1))
Arrondir = Int(Arrondir * 10 ^ NbreDeci) / 10 ^ NbreDeci
End Function
Function NombreToArabe(ByVal Total As Double) As String
Dim Millions As Double
Dim Milliers As Double
Dim cent As Double
Dim decimales As Double
Dim T0 As String
Dim T1 As String
Dim T2 As String
Dim T3 As String
Dim Resultat As String
Dim T As String
Total = Arrondir(Total, 2)
Millions = Int(Modulo(Int(Total / 1000000), 1000))
Milliers = Int(Modulo(Int(Total / 1000), 1000))
cent = Int(Modulo(Total, 1000))
decimales = Arrondir((Modulo(Total * 100, 100)), 0)
T0 = lireCentaine(Millions)
T1 = lireCentaine(Milliers)
T2 = lireCentaine(cent)
T3 = lireCentaine(decimales)
If T0 <> "" Then
If (T1 <> "") Then
If (T2 <> "") Then
T0 = T0
T1 = " و " & T1
T2 = " و " & T2
End If
End If
End If
If T0 = "" Then
If (T1 <> "") Then
If (T2 <> "") Then
T0 = T0
T1 = T1
T2 = " و " & T2
End If
End If
End If
If T0 <> "" Then
If (T1 <> "") Then
If (T2 = "") Then
T0 = T0
T1 = " و " & T1
T2 = T2
End If
End If
End If
If T0 = "" Then
If (T1 <> "") Then
If (T2 = "") Then
T0 = T0
T1 = T1
T2 = T2
End If
End If
End If
If T0 <> "" Then
If (T2 <> "") Then
If (T1 = "") Then
T0 = T0
T2 = " و " & T2
T1 = T1
End If
End If
End If
If T0 = "" Then
If (T2 <> "") Then
If (T1 = "") Then
T0 = T0
T1 = T1
T2 = T2
End If
End If
End If
If T0 = "واحد" Then
T0 = ""
Resultat = Resultat & T0 & " مليون "
End If
If T0 = "إثنان" Then
T0 = ""
Resultat = Resultat & T0 & " مليونان "
End If
If Millions >= 3 And Millions <= 10 Then
Resultat = Resultat & T0 & " ملايين "
End If
If Millions >= 11 And Millions <= 999 Then
Resultat = Resultat & T0 & " مليون "
Else
Resultat = Resultat & ""
End If
If T1 = "واحد" Then
T1 = ""
Resultat = Resultat & T1 & " ألف "
End If
If T1 = "إثنان" Then
T1 = ""
Resultat = Resultat & T1 & " ألفان "
End If
If Milliers >= 3 And Milliers <= 10 Then
Resultat = Resultat & T1 & " ألاف "
End If
If Milliers >= 11 And Milliers <= 999 Then
Resultat = Resultat & T1 & " ألف "
Else
Resultat = Resultat & ""
End If
If T2 <> "" Then
Resultat = Resultat & T2 & " دج "
Else
If Resultat <> "" Then
Resultat = Resultat & " دج "
End If
End If
If T3 <> "" Then
If Resultat <> "" Then
Resultat = Resultat & " و " & T3 & " سنتيما"
Else
Resultat = T3 & " سنتيما"
End If
End If
NombreToArabe = Resultat
End Function
بعد ذلك اضغط على run sub وهو عبارة عن نافذة صغيرة على شكل مثلث لتظهر لك نافذة macros name قم يتسميتها اي اسم ثم احفظ العملية لك الخيار في جعلها تطبق على هذا المف او على كل ملفات الاكسال في السطر الاخير من نافذة الحفظ
ثم اغلق صفحة محرر الباسيك وعد لصفحة الاكسال ثم اضغط على الخانة التي ترغب في وضع وكتابة الحروف بها ثم اضغط على قائمة ادارج ثم دالة وابحث عن اسم الدالة وهو NombreToArabe ثم اضغط على الرقم المراد تحويله لحروف وسوف يقوم الاكسال تلقائيا بتحويل الرقام لحروف في كل مرة تغير فيها الرقم
وبالتوفيق لاتنسوا الدعاء بالخير
