10:52 AM |الساعة الآن   
 
العودة ملتقى الموظف الجزائرى  :: 

منتدى ادارة الجماعات الاقليمية

 :: 

الميزانية المحلية






أهلا وسهلا بك إلى ملتقى الموظف الجزائرى.
أهلا وسهلا بك زائرنا الكريم، إذا كانت هذه زيارتك الأولى للمنتدى، فيرجى التكرم بزيارة صفحة التعليمـــات، بالضغط هنا.كما يشرفنا أن تقوم بالتسجيل بالضغط هنا إذا رغبت بالمشاركة في المنتدى، أما إذا رغبت بقراءة المواضيع والإطلاع فتفضل بزيارة القسم الذي ترغب أدناه.

الرئيسيةالبوابةبحـثس .و .جدخولالتسجيل
اعلان هام للمسجلين الجدد :بمجرد التسجيل يتم إرسال كود التفعيل إلى حسابك .. أي الإيميل الذي وضعته عند التسجيل بالمنتدى ... إذهب إلى علبة البريد فإذا لم تجده في الرسائل الواردة حاول أن تبحث عنه في صندوق بريد الغير مرغوب فيه SPAM



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


شاطر
 #1  
السبت 12 مارس 2011, 15:14
 
 
 
ذكر
الاقامة : algerie
المشاركات : 159
نقاط : 242
تاريخ التسجيل : 23/01/2011
العمر : 41
العمل : adminisrateur
المزاج المزاج : مرح وبشوش دائما
افتراضيلمن يرغب في تحويل الارقام لحروف بالعربية

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


 #2  
الأحد 01 مايو 2011, 14:54
 
 
 
ذكر
الاقامة : ميلة
المشاركات : 13
نقاط : 13
تاريخ التسجيل : 30/04/2011
العمل : موظف
افتراضيرد: لمن يرغب في تحويل الارقام لحروف بالعربية

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


 #3  
الأحد 01 مايو 2011, 18:53
 
 
 
ذكر
الاقامة : الجزائر
المشاركات : 212
نقاط : 322
تاريخ التسجيل : 16/10/2010
العمل : موظف
المزاج المزاج : رايق مبسوط تماما
افتراضيرد: لمن يرغب في تحويل الارقام لحروف بالعربية

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


 #4  
الجمعة 13 مايو 2011, 11:26
 
 
 
ذكر
الاقامة : الجزائر
المشاركات : 142
نقاط : 161
تاريخ التسجيل : 18/01/2011
العمل : موظف
افتراضيرد: لمن يرغب في تحويل الارقام لحروف بالعربية

merci....merci






 
الإشارات المرجعية


  
وما من كاتب إلا سيفنى . ويبقي الدهر ما كتبت يداه



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

BB code is متاحة
كود [IMG] متاحة
كود HTML متاحة