محمد اليازجي قام بنشر مايو 6, 2013 قام بنشر مايو 6, 2013 اولا اشكر لكم متابعتكم اريد الكيفية التي استطيع فيها تحويل الارقام الى حروف مثلا 1500$ فقط ألف وخمسمائة دولار لاغير وهكذا ويكون متضمن الكسور بارك الله فيكم
شوقي ربيع قام بنشر مايو 6, 2013 قام بنشر مايو 6, 2013 شاهد هذا الرابط http://www.officena.net/ib/index.php?showtopic=45870
هادى محمد المامون سالم قام بنشر مايو 6, 2013 قام بنشر مايو 6, 2013 (معدل) بسم الله الرحمن الرحيم مرفق داله جاهزه وجدتها فى خزينتى للتفقيط الى دولار مرفق ملف السلام عليكم تفقيط دولار.rar تم تعديل مايو 6, 2013 بواسطه هادى محمد المامون سالم
محمد اليازجي قام بنشر مايو 6, 2013 الكاتب قام بنشر مايو 6, 2013 اولا اشكر لكم متابعتكم اريد الكيفية التي استطيع فيها تحويل الارقام الى حروف مثلا 1500$ فقط ألف وخمسمائة دولار لاغير وهكذا ويكون متضمن الكسور تابعوا هذا الملف فلقد وجدت الحل فيه وشكرا لكل من ساعدني 1. اضغطALT+F11 لبدءVisual Basic Editor. 3. On the Insert menu, click Module. 4. خذ هذا الكود وادخله داخل المودل. Option Explicit 'Main Function Function SpellNumber(ByVal MyNumber) Dim Dollars, Cents, Temp Dim DecimalPlace, Count ReDim Place(9) As String Place(2) = " Thousand " Place(3) = " Million " Place(4) = " Billion " Place(5) = " Trillion " ' String representation of amount. MyNumber = Trim(Str(MyNumber)) ' Position of decimal place 0 if none. DecimalPlace = InStr(MyNumber, ".") ' Convert cents and set MyNumber to dollar amount. If DecimalPlace > 0 Then Cents = 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 Dollars = Temp & Place(Count) & Dollars If Len(MyNumber) > 3 Then MyNumber = Left(MyNumber, Len(MyNumber) - 3) Else MyNumber = "" End If Count = Count + 1 Loop Select Case Dollars Case "" Dollars = "No Dollars" Case "One" Dollars = "One Dollar" Case Else Dollars = Dollars & " Dollars" End Select Select Case Cents Case "" Cents = " and No Cents" Case "One" Cents = " and One Cent" Case Else Cents = " and " & Cents & " Cents" End Select SpellNumber = Dollars & Cents End Function ' Converts a number from 100-999 into text Function GetHundreds(ByVal MyNumber) Dim Result As String If Val(MyNumber) = 0 Then Exit Function MyNumber = Right("000" & MyNumber, 3) ' Convert the hundreds place. If Mid(MyNumber, 1, 1) <> "0" Then Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred " End If ' Convert the tens and ones place. 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 ' Converts a number from 10 to 99 into text. Function GetTens(TensText) Dim Result As String Result = "" ' Null out the temporary function value. If Val(Left(TensText, 1)) = 1 Then ' If value between 10-19... 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" Case Else End Select Else ' If value between 20-99... 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 " Case Else End Select Result = Result & GetDigit _ (Right(TensText, 1)) ' Retrieve ones place. End If GetTens = Result End Function ' Converts a number from 1 to 9 into text. Function GetDigit(Digit) 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 في الخلية التي تريد فيها تحويل الارقام الى احرف اكتب المعادلة التالية =SpellNumber(A1) مثلا في الخلية a1 وستظهر لكل الارقم قد تحولت الى احرف بارك الله فيكم
محمد اليازجي قام بنشر مايو 6, 2013 الكاتب قام بنشر مايو 6, 2013 اولا اشكر لكم متابعتكم اريد الكيفية التي استطيع فيها تحويل الارقام الى حروف مثلا 1500$ فقط ألف وخمسمائة دولار لاغير وهكذا ويكون متضمن الكسور تابعوا هذا الملف فلقد وجدت الحل فيه وشكرا لكل من ساعدني 1. اضغطALT+F11 لبدءVisual Basic Editor. 3. On the Insert menu, click Module. 4. خذ هذا الكود وادخله داخل المودل. Option Explicit 'Main Function Function SpellNumber(ByVal MyNumber) Dim Dollars, Cents, Temp Dim DecimalPlace, Count ReDim Place(9) As String Place(2) = " Thousand " Place(3) = " Million " Place(4) = " Billion " Place(5) = " Trillion " ' String representation of amount. MyNumber = Trim(Str(MyNumber)) ' Position of decimal place 0 if none. DecimalPlace = InStr(MyNumber, ".") ' Convert cents and set MyNumber to dollar amount. If DecimalPlace > 0 Then Cents = 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 Dollars = Temp & Place(Count) & Dollars If Len(MyNumber) > 3 Then MyNumber = Left(MyNumber, Len(MyNumber) - 3) Else MyNumber = "" End If Count = Count + 1 Loop Select Case Dollars Case "" Dollars = "No Dollars" Case "One" Dollars = "One Dollar" Case Else Dollars = Dollars & " Dollars" End Select Select Case Cents Case "" Cents = " and No Cents" Case "One" Cents = " and One Cent" Case Else Cents = " and " & Cents & " Cents" End Select SpellNumber = Dollars & Cents End Function ' Converts a number from 100-999 into text Function GetHundreds(ByVal MyNumber) Dim Result As String If Val(MyNumber) = 0 Then Exit Function MyNumber = Right("000" & MyNumber, 3) ' Convert the hundreds place. If Mid(MyNumber, 1, 1) <> "0" Then Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred " End If ' Convert the tens and ones place. 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 ' Converts a number from 10 to 99 into text. Function GetTens(TensText) Dim Result As String Result = "" ' Null out the temporary function value. If Val(Left(TensText, 1)) = 1 Then ' If value between 10-19... 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" Case Else End Select Else ' If value between 20-99... 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 " Case Else End Select Result = Result & GetDigit _ (Right(TensText, 1)) ' Retrieve ones place. End If GetTens = Result End Function ' Converts a number from 1 to 9 into text. Function GetDigit(Digit) 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 في الخلية التي تريد فيها تحويل الارقام الى احرف اكتب المعادلة التالية =SpellNumber(A1) مثلا في الخلية a1 وستظهر لكل الارقم قد تحولت الى احرف بارك الله فيكم هل هناك امكانية لاظهار الحروف باللغة العربية
حمادة عمر قام بنشر مايو 6, 2013 قام بنشر مايو 6, 2013 الاخ الكريم / محمد اليازجي جاء الرد علي طلبك الاخير بخصوص التفقيط بالعربي في الرابط المرسل من الاخ الحبيب / شوقي ربيع .. جزاه الله خيرا ... وهو يفي بالمطلوب واليك كود آخر ... قم بوضع الكود التالي في مودل Function NoToTxt(TheNo As Double, MyCur As String, MySubCur As String) As String Dim MyArry1(0 To 9) As String Dim MyArry2(0 To 9) As String Dim MyArry3(0 To 9) As String Dim Myno As String Dim GetNo As String Dim RdNo As String Dim My100 As String Dim My10 As String Dim My1 As String Dim My11 As String Dim My12 As String Dim GetTxt As String Dim Mybillion As String Dim MyMillion As String Dim MyThou As String Dim MyHun As String Dim MyFraction As String Dim MyAnd As String Dim i As Integer Dim ReMark As String If TheNo > 999999999999.99 Then Exit Function If TheNo < 0 Then TheNo = TheNo * -1 ReMark = "íÊÈÞì áßã " Else ReMark = "ÝÞØ " End If If TheNo = 0 Then NoToTxt = "ÕÝÑ" Exit Function End If MyAnd = " æ" MyArry1(0) = "" MyArry1(1) = "ãÇÆÉ" MyArry1(2) = "ãÇÆÊÇä" MyArry1(3) = "ËáÇËãÇÆÉ" MyArry1(4) = "ÃÑÈÚãÇÆÉ" MyArry1(5) = "ÎãÓãÇÆÉ" MyArry1(6) = "ÓÊãÇÆÉ" MyArry1(7) = "ÓÈÚãÇÆÉ" MyArry1(8) = "ËãÇäãÇÆÉ" MyArry1(9) = "ÊÓÚãÇÆÉ" MyArry2(0) = "" MyArry2(1) = " ÚÔÑ" MyArry2(2) = "ÚÔÑæä" MyArry2(3) = "ËáÇËæä" MyArry2(4) = "ÃÑÈÚæä" MyArry2(5) = "ÎãÓæä" MyArry2(6) = "ÓÊæä" MyArry2(7) = "ÓÈÚæä" MyArry2(8) = "ËãÇäæä" MyArry2(9) = "ÊÓÚæä" MyArry3(0) = "" MyArry3(1) = "æÇÍÏ" MyArry3(2) = "ÇËäÇä" MyArry3(3) = "ËáÇËÉ" MyArry3(4) = "ÃÑÈÚÉ" MyArry3(5) = "ÎãÓÉ" MyArry3(6) = "ÓÊÉ" MyArry3(7) = "ÓÈÚÉ" MyArry3(8) = "ËãÇäíÉ" MyArry3(9) = "ÊÓÚÉ" '====================== GetNo = Format(TheNo, "000000000000.00") i = 0 Do While i < 15 If i < 12 Then Myno = Mid$(GetNo, i + 1, 3) Else Myno = "0" + Mid$(GetNo, i + 2, 2) End If If (Mid$(Myno, 1, 3)) > 0 Then RdNo = Mid$(Myno, 1, 1) My100 = MyArry1(RdNo) RdNo = Mid$(Myno, 3, 1) My1 = MyArry3(RdNo) RdNo = Mid$(Myno, 2, 1) My10 = MyArry2(RdNo) If Mid$(Myno, 2, 2) = 11 Then My11 = "ÅÍÏì ÚÔÑ" If Mid$(Myno, 2, 2) = 12 Then My12 = "ÅËäì ÚÔÑ" If Mid$(Myno, 2, 2) = 10 Then My10 = "ÚÔÑÉ" If ((Mid$(Myno, 1, 1)) > 0) And ((Mid$(Myno, 2, 2)) > 0) Then My100 = My100 + MyAnd If ((Mid$(Myno, 3, 1)) > 0) And ((Mid$(Myno, 2, 1)) > 1) Then My1 = My1 + MyAnd GetTxt = My100 + My1 + My10 If ((Mid$(Myno, 3, 1)) = 1) And ((Mid$(Myno, 2, 1)) = 1) Then GetTxt = My100 + My11 If ((Mid$(Myno, 1, 1)) = 0) Then GetTxt = My11 End If If ((Mid$(Myno, 3, 1)) = 2) And ((Mid$(Myno, 2, 1)) = 1) Then GetTxt = My100 + My12 If ((Mid$(Myno, 1, 1)) = 0) Then GetTxt = My12 End If If (i = 0) And (GetTxt <> "") Then If ((Mid$(Myno, 1, 3)) > 10) Then Mybillion = GetTxt + " ãáíÇÑ" Else Mybillion = GetTxt + " ãáíÇÑÇÊ" If ((Mid$(Myno, 1, 3)) = 2) Then Mybillion = " ãáíÇÑ" If ((Mid$(Myno, 1, 3)) = 2) Then Mybillion = " ãáíÇÑÇä" End If End If If (i = 3) And (GetTxt <> "") Then If ((Mid$(Myno, 1, 3)) > 10) Then MyMillion = GetTxt + " ãáíæä" Else MyMillion = GetTxt + " ãáÇííä" If ((Mid$(Myno, 1, 3)) = 1) Then MyMillion = " ãáíæä" If ((Mid$(Myno, 1, 3)) = 2) Then MyMillion = " ãáíæäÇä" End If End If If (i = 6) And (GetTxt <> "") Then If ((Mid$(Myno, 1, 3)) > 10) Then MyThou = GetTxt + " ÃáÝ" Else MyThou = GetTxt + " ÂáÇÝ" If ((Mid$(Myno, 3, 1)) = 1) Then MyThou = " ÃáÝ" If ((Mid$(Myno, 3, 1)) = 2) Then MyThou = " ÃáÝÇä" End If End If If (i = 9) And (GetTxt <> "") Then MyHun = GetTxt If (i = 12) And (GetTxt <> "") Then MyFraction = GetTxt End If i = i + 3 Loop If (Mybillion <> "") Then If (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then Mybillion = Mybillion + MyAnd End If If (MyMillion <> "") Then If (MyThou <> "") Or (MyHun <> "") Then MyMillion = MyMillion + MyAnd End If If (MyThou <> "") Then If (MyHun <> "") Then MyThou = MyThou + MyAnd End If If MyFraction <> "" Then If (Mybillion <> "") Or (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then NoToTxt = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur + MyAnd + MyFraction + " " + MySubCur Else NoToTxt = ReMark + MyFraction + " " + MySubCur End If Else NoToTxt = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur End If End Function ثم ضع المعادلة التاليه في الخليه التي تريد فيها التفقيط =NOTOTXT(A1;"جنيهاً";"قرشاً") جزاك الله خيرا
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.