كود تحويل الأرقام إلى حروف باللغة الإنجليزية

[عبد الفتاح كيرة]

السلام عليكم

هذا كود ورد إلى بريدى

وظيفة لتحويل الأرقام إلى حروف

يجب تخفيض إعدادات الأمان

و تمكين الوصول إلى مشروع vba

طريقة العمل

تفتح

الملف المرفق

افتح ملفا جديدا

من الملف الأصلى اضغط تصدير الكود للملف المفتوح

سيتم تصدير الوظيفة للملف الجديد

ابدأ باستخدام الوظيفة كأى دالة فى إكسل

اكتب رقما فى خلية و لتكن a1

و فى خلية مجاورة اكتب

=NumsToWords(A1)

هذا هو الكود

Option Explicit

' Downloaded from www.contextures.com

'*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*

'* NumsToWords(NumSource, MajorCurrency, MinorCurrency, MajorMinorLink) function					 *

'*																								   *

'* Where:Words																					   *

'* NumSource:	  Number, or cell reference containing the number, to be converted to words		 *

'* MajorCurrency:  Primary currency name.......................... (Optional: Default is "Dollar")   *

'* MinorCurrency:  Secondary currency name........................ (Optional: Default is "Cent")	 *

'* MajorMinorLink: Word to connect Major and Minor Currency....... (Optional: Default is "and")	  *

'* SkipMinor:	  True/False flag to ignore the MinorCurrency.... (Optional: Default is FALSE)	  *

'*																								   *

'* Programmer:    Ron Coderre																		   *

'* Created on:    14-JUL-2007																		   *

'* Last Modified: 24-MAR-2009																		   *

'*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*.*

Public Function NumsToWords( _

   NumSource As Currency, _

   Optional MajorCurrency As String = "Dollar", _

   Optional MinorCurrency As String = "Cent", _

   Optional MajorMinorLink As String = "and", _

   Optional SkipMinor As Boolean = False _

   ) As String


Dim Words As String	   ' Used to build the word phrase

Dim WIPnum As String	  ' Orig number formatted as 000000000000000.00

Dim LU_NumList()		  ' Array of numbers to match during the process

Dim LU_NumText()		  ' Text values associated with LU_NumList values

Dim iMisc As Integer	  ' Container for interim calculations

Dim iCtr As Integer	   ' Counter variable

Dim LU_Denom()		    ' Array of groups (Trillion, Billion, etc)

Dim DecSepChar		    ' Decimal separator symbol ( eg English: . )

LU_NumList = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, _

				  11, 12, 13, 14, 15, 16, 17, 18, 19, _

				  20, 30, 40, 50, 60, 70, 80, 90)[/center]



[center]LU_NumText = Array("", " One", " Two", " Three", " Four", " Five", _

   " Six", " Seven", " Eight", " Nine", " Ten", " Eleven", _

   " Twelve", " Thirteen", " Fourteen", " Fifteen", " Sixteen", _

   " Seventeen", " Eighteen", " Nineteen", " Twenty", " Thirty", _

   " Forty", " Fifty", " Sixty", " Seventy", " Eighty", " Ninety")[/center]


[center]DecSepChar = Application.International(xlDecimalSeparator)[/center]



[center]LU_Denom = Array(" Trillion", " Billion", " Million", " Thousand", "", "")[/center]


[center]WIPnum = Replace(Format(Abs(NumSource), "000000000000000.00;KillFlow"), DecSepChar, "0")[/center]



[center]'Pull successive WIPnum triads and assign word values

For iCtr = 0 To 5

   iMisc = CInt(Mid(WIPnum, (1 + iCtr * 3), 3))


   If Int(iMisc / 100) > 0 Then Words = Words & LU_NumText(Int(iMisc / 100)) & " Hundred"


   'Set the tens and ones phrase

   If (iMisc Mod 100) > 19 Then

	  Words = Words & LU_NumText(Int((iMisc Mod 100) / 10) + 18) & LU_NumText(iMisc Mod 10)

   Else

	  Words = Words & LU_NumText(iMisc Mod 100)

   End If


   If iMisc > 0 Then Words = Words & LU_Denom(iCtr)


   If iCtr = 4 Then  ' Finish building the whole nums phrase

	  Words = Words & " " & MajorCurrency

	  If Int(NumSource) = 0 Then Words = "No" & Words

	  If Int(NumSource) <> 1 And MajorCurrency <> "" Then Words = Words & "s"

	  If SkipMinor = False Then Words = Words & " " & MajorMinorLink Else Exit For


   ElseIf iCtr = 5 Then 'Complete the MinorCurrency phrase

	  If SkipMinor = False Then

		 If iMisc = 0 Then Words = Words & " No"

		 Words = Words & " " & MinorCurrency

		 If iMisc <> 1 And MinorCurrency <> "" Then Words = Words & "s"

	  End If

   End If

Next iCtr[/center]


[center]NumsToWords = Trim(Replace(Words, "  ", " "))

End Function[/center]



[center]

و الملف مرة أخرى بالمرفقات

و بعد إذن الإدارة

هذا

مصدر الموضوع

أرجو أن تنتفعوا به

[عبدالله المجرب]

ابا عمر

هناك مثل يقول من طول الغيبات جاب الغنائم

وهذا الكود باين انه بداية الغنائم

ان شاء الله نراك دوماً منور منتدنا يا ابا عمر

ابواحمد

[عبد الفتاح كيرة]

حياك الله أخى عبد الله

وبارك فيك

أحاول التواجد قدر المستطاع

و الله المستعان

[ياسر الحافظ]

استاذنا الغالي " ابو عمر " كيمــــــــــــــــــــــــــــاس

تشكر ... وجزاك الله كل الخير

وفقك الله

ابو الحارث

[الـعيدروس]

استاذنا الحبيب كيماس حفظك الله ورعاك

جزاك الله خير على هذه النقلة المتميزة

الى الامام

تقبل مروري

[MAHMOUD ALI YOUSSEF]

السلام عليكم

اكواد قمة في الروعة

جزاكم الله كل خير :fff:

[عبد الفتاح كيرة]

أشكر كل إخوانى الطيبين

الأخ ياسر

والأخ على

والأخ محمود

على طيب كلامكم

وفقكم الله لكل خير

[saad abed]

اخى عبدالفتاح (ابوعمر)

جزاك الله كل خير

تعلمنا منك الكثير اولها البحث وحب الجديد

ادام الله عليك الصحة والعافية

تحياتى

سعد عابد