Great Idea Hemant!!
Here goes my code!!
The following code is to Convert Currency to Words(Indian Style)
'Please make a Module and add the code...
Option Explicit
' Function for conversion of a Currency to words
' Parameter - accept a Currency
' Returns the number in words format
'*************************************************
Function CurrencyToWord(ByVal MyNumber)
Dim Temp
Dim Rupees, Paisa As String
Dim DecimalPlace, iCount
Dim Hundreds, Words As String
ReDim Place(9) As String
Place(0) = " Thousand "
Place(2) = " Lakh "
Place(4) = " Crore "
Place(6) = " Arab "
Place(8) = " Kharab "
On Error Resume Next
' Convert MyNumber to a string, trimming extra spaces.
MyNumber = Trim(Str(MyNumber))
' Find decimal place.
DecimalPlace = InStr(MyNumber, ".")
' If we find decimal place...
If DecimalPlace > 0 Then
' Convert Paisa
Temp = Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2)
Paisa = " and " & ConvertTens(Temp) & " Paisa"
' Strip off paisa from remainder to convert.
MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
End If
' Convert last 3 digits of MyNumber to ruppees in word.
Hundreds = ConvertHundreds(Right(MyNumber, 3))
' Strip off last three digits
MyNumber = Left(MyNumber, Len(MyNumber) - 3)
iCount = 0
Do While MyNumber <> ""
'Strip last two digits
Temp = Right(MyNumber, 2)
If Len(MyNumber) = 1 Then
Words = ConvertDigit(Temp) & Place(iCount) & Words
MyNumber = Left(MyNumber, Len(MyNumber) - 1)
Else
Words = ConvertTens(Temp) & Place(iCount) & Words
MyNumber = Left(MyNumber, Len(MyNumber) - 2)
End If
iCount = iCount + 2
Loop
CurrencyToWord = "Rupees " & Words & Hundreds & Paisa
End Function
' Conversion for hundreds
'*****************************************
Private Function ConvertHundreds(ByVal MyNumber)
Dim Result As String
' Exit if there is nothing to convert.
If Val(MyNumber) = 0 Then Exit Function
' Append leading zeros to number.
MyNumber = Right("000" & MyNumber, 3)
' Do we have a hundreds place digit to convert?
If Left(MyNumber, 1) <> "0" Then
Result = ConvertDigit(Left(MyNumber, 1)) & " Hundreds "
End If
' Do we have a tens place digit to convert?
If Mid(MyNumber, 2, 1) <> "0" Then
Result = Result & ConvertTens(Mid(MyNumber, 2))
Else
' If not, then convert the ones place digit.
Result = Result & ConvertDigit(Mid(MyNumber, 3))
End If
ConvertHundreds = Trim(Result)
End Function
' Conversion for tens
'*****************************************
Private Function ConvertTens(ByVal MyTens)
Dim Result As String
' Is value between 10 and 19?
If Val(Left(MyTens, 1)) = 1 Then
Select Case Val(MyTens)
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
' .. otherwise it's between 20 and 99.
Select Case Val(Left(MyTens, 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
' Convert ones place digit.
Result = Result & ConvertDigit(Right(MyTens, 1))
End If
ConvertTens = Result
End Function
Private Function ConvertDigit(ByVal MyDigit)
Select Case Val(MyDigit)
Case 1: ConvertDigit = "One"
Case 2: ConvertDigit = "Two"
Case 3: ConvertDigit = "Three"
Case 4: ConvertDigit = "Four"
Case 5: ConvertDigit = "Five"
Case 6: ConvertDigit = "Six"
Case 7: ConvertDigit = "Seven"
Case 8: ConvertDigit = "Eight"
Case 9: ConvertDigit = "Nine"
Case Else: ConvertDigit = ""
End Select
End Function
Regards,
Andy
On Mon, Nov 23, 2009 at 10:07 AM, Ayush <jainayus...@gmail.com> wrote:
> Great Thought Hemant !!
>
> and I will try to post all these codes on our blog
> www.vbamacros.blogspot.com
> accessible to all members all the times :)
>
> On Nov 21, 4:49 pm, Hemant Hegde <hemantbales...@gmail.com> wrote:
> > Why not we share some of our own useful codes or techniques (which can
> not
> > be easily found by a google search) which will save lot of effort and
> time?
> > :)
> > I am going to post some of the vb codes I wrote or got on the net.
> >
> > I will post a function (tomorrow because I don't have it here!) I wrote
> > which will adjust the size of a userform to the screen size and also will
> > distribute all the controls in it without overlapping on each other.
> >
> > Please post yours
>
> --
>
> ----------------------------------------------------------------------------------
> Some important links for excel users:
> 1. Excel and VBA Tutorials(Video and Text), Free add-ins downloads at
> http://www.excelitems.com
> 2. Excel tutorials at http://www.excel-macros.blogspot.com
> 3. Learn VBA Macros at http://www.vbamacros.blogspot.com
> 4. Excel Tips and Tricks at http://exceldailytip.blogspot.com
>
>
> To post to this group, send email to excel-macros@googlegroups.com
> If you find any spam message in the group, please send an email to:
> Ayush Jain @ jainayus...@gmail.com or
> Ashish Jain @ 26may.1...@gmail.com
> <><><><><><><><><><><><><><><><><><><><><><>
> HELP US GROW !!
>
> We reach over 6,500 subscribers worldwide and receive many nice notes about
> the learning and support from the group. Our goal is to have 10,000
> subscribers by the end of 2009. Let friends and co-workers know they can
> subscribe to group at
> http://groups.google.com/group/excel-macros/subscribe
--
----------------------------------------------------------------------------------
Some important links for excel users:
1. Excel and VBA Tutorials(Video and Text), Free add-ins downloads at
http://www.excelitems.com
2. Excel tutorials at http://www.excel-macros.blogspot.com
3. Learn VBA Macros at http://www.vbamacros.blogspot.com
4. Excel Tips and Tricks at http://exceldailytip.blogspot.com
To post to this group, send email to excel-macros@googlegroups.com
If you find any spam message in the group, please send an email to:
Ayush Jain @ jainayus...@gmail.com or
Ashish Jain @ 26may.1...@gmail.com
<><><><><><><><><><><><><><><><><><><><><><>
HELP US GROW !!
We reach over 6,500 subscribers worldwide and receive many nice notes about the
learning and support from the group. Our goal is to have 10,000 subscribers by
the end of 2009. Let friends and co-workers know they can subscribe to group at
http://groups.google.com/group/excel-macros/subscribe
