لمن يرغب في تحويل الارقام لحروف بالعربية

استعرض الموضوع السابق استعرض الموضوع التالي اذهب الى الأسفل

لمن يرغب في تحويل الارقام لحروف بالعربية

مُساهمة من طرف bachirmess في السبت 12 مارس 2011, 15:14

الافيس يجب ان يكون 2003
افتح صفحة الاكسال واضغط على الخانة التي ترغب التحويل اليها
بعد ذلك توجه لقائمة ادوات واضغط على ماكرو ثم على محرر الفيزيال بازيك فتظهر لك صفحة جديدة فارغة للمحرر
ثم اختار 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 ثم اضغط على الرقم المراد تحويله لحروف وسوف يقوم الاكسال تلقائيا بتحويل الرقام لحروف في كل مرة تغير فيها الرقم
وبالتوفيق لاتنسوا الدعاء بالخير
avatar
bachirmess
 
 

ذكر

الاقامة : algerie

المشاركات : 159

نقاط : 242

تاريخ التسجيل : 23/01/2011

العمر : 42

العمل : adminisrateur
المزاج المزاج : مرح وبشوش دائما


الرجوع الى أعلى الصفحة اذهب الى الأسفل

رد: لمن يرغب في تحويل الارقام لحروف بالعربية

مُساهمة من طرف karim1974dz في الأحد 01 مايو 2011, 14:54

شكـــرا ، لقد جربته إته رائع ، جعله الله في ميزان حسناتك
avatar
karim1974dz
 
 

ذكر

الاقامة : ميلة

المشاركات : 13

نقاط : 13

تاريخ التسجيل : 30/04/2011

العمل : موظف

الرجوع الى أعلى الصفحة اذهب الى الأسفل

رد: لمن يرغب في تحويل الارقام لحروف بالعربية

مُساهمة من طرف الفنوس في الأحد 01 مايو 2011, 18:53

شكرا لك و بارك الله فيك في انتظار التجريب
avatar
الفنوس
 
 

ذكر

الاقامة : الجزائر

المشاركات : 212

نقاط : 322

تاريخ التسجيل : 16/10/2010

العمل : موظف
المزاج المزاج : رايق مبسوط تماما


الرجوع الى أعلى الصفحة اذهب الى الأسفل

رد: لمن يرغب في تحويل الارقام لحروف بالعربية

مُساهمة من طرف abdude1976 في الجمعة 13 مايو 2011, 11:26

merci....merci
avatar
abdude1976
 
 

ذكر

الاقامة : الجزائر

المشاركات : 142

نقاط : 161

تاريخ التسجيل : 18/01/2011

العمل : موظف

الرجوع الى أعلى الصفحة اذهب الى الأسفل

استعرض الموضوع السابق استعرض الموضوع التالي الرجوع الى أعلى الصفحة

إنشاء حساب أو تسجيل الدخول لتستطيع الرد

تحتاج إلى أن يكون عضوا لتستطيع الرد.

انشئ حساب

يمكنك الانضمام للمنتدى فهملية التسجيل سهلة !


انشاء حساب جديد

تسجيل الدخول

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


تسجيل الدخول

 
صلاحيات هذا المنتدى:
لاتستطيع الرد على المواضيع في هذا المنتدى

  • © phpBB | Ahlamontada.com | منتدى مجاني للدعم و المساعدة | إتصل بنا | التبليغ عن محتوى مخالف | انشئ مدونتك الخاصة