Use the complete following code by copy & paste in the VBA Editor (Alt+F11)
and use the function =N2W to conver Numbers to Words:
Public Function N2W(ByVal dbMyNumber As Double, _
Optional ByVal sMainUnitPlural As String, _
Optional ByVal sMainUnitSingle As String, _
Optional ByVal sDecimalUnitPlural As String = "", _
Optional ByVal sDecimalUnitSingle As String = "")
Dim sMyNumber As String
Dim sCurrency As String
Dim sDecimalText As String
Dim sTemp As String
Dim iDecimalPlace As Integer
Dim iCount As Integer
Call Application.Volatile(True)
ReDim Place(9) As String
Application.Volatile (True)
Place(2) = "Thousand"
Place(3) = "Million"
Place(4) = "Billion"
Place(5) = "Trillion"
sMyNumber = Trim(CStr(dbMyNumber))
iDecimalPlace = InStr(dbMyNumber, ".")
If iDecimalPlace > 0 Then
sDecimalText = GetTens(Left(Mid(Round(sMyNumber, 2), iDecimalPlace +
1) & "00", 2))
If Len(sDecimalText) > 0 Then
sMyNumber = Trim(Left(sMyNumber, iDecimalPlace - 1))
Else
sMyNumber = ""
End If
End If
iCount = 1
Do While sMyNumber <> ""
sTemp = GetHundreds(sMyNumber, Right(sMyNumber, 3), iDecimalPlace)
If sTemp <> "" Then
If (iCount > 1) And (LCase(Left(Trim(sCurrency), 3)) <> "and") Then
sCurrency = " " & sCurrency
End If
sCurrency = sTemp & Place(iCount) & sCurrency
End If
If Len(sMyNumber) > 3 Then
sMyNumber = Left(sMyNumber, Len(sMyNumber) - 3)
Else
sMyNumber = ""
End If
iCount = iCount + 1
Loop
Select Case Trim(sCurrency)
Case "": sCurrency = "Zero " & sMainUnitPlural
Case "One": sCurrency = "One " & sMainUnitSingle
Case Else: sCurrency = sCurrency & sMainUnitPlural
End Select
If iDecimalPlace > 0 Then
' If (Len(sDecimalUnitPlural) > 0 And Len(sDecimalUnitSingle) > 0) Then
sCurrency = sCurrency & " "
Select Case Trim(sDecimalText)
Case "": sDecimalText = "and Zero " & sDecimalUnitPlural
Case "One": sDecimalText = "and One " & sDecimalUnitSingle
Case Else: sDecimalText = "and " & sDecimalText &
sDecimalUnitPlural
End Select
' Else
' sCurrency = sCurrency & " and "
' sDecimalText = Mid(Trim(Str(dbMyNumber)), iDecimalPlace + 1) & "/100"
' End If
End If
N2W = Trim(sCurrency & sDecimalText)
End Function
Function GetHundreds(ByVal sMyNumber As String, _
ByVal sHundredNumber As String, _
ByVal iDecimal As Integer) As String
Dim sResult As String
If sHundredNumber = "0" Then Exit Function
sHundredNumber = Right("000" & sHundredNumber, 3)
If Mid(sHundredNumber, 1, 1) = "0" Then
sResult = GetDigit(Mid(sHundredNumber, 1, 1))
ElseIf Mid(sHundredNumber, 1, 1) <> "0" Then
sResult = GetDigit(Mid(sHundredNumber, 1, 1)) & "Hundred"
End If
If (sMyNumber > 1000) And (Mid(sHundredNumber, 3, 1) <> "0" Or _
Mid(sHundredNumber, 2, 1) <> "0") Or _
(Len(sResult) > 0) And (Mid(sHundredNumber, 3, 1) <> "0" Or _
Mid(sHundredNumber, 2, 1) <> "0") Then
sResult = sResult & " and "
End If
If Mid(sHundredNumber, 2, 1) <> "0" Then
sResult = sResult & GetTens(Mid(sHundredNumber, 2))
Else
If Mid(sHundredNumber, 3, 1) <> "0" Then
sResult = sResult & GetDigit(Mid(sHundredNumber, 3))
Else
If Mid(sHundredNumber, 1, 1) <> "0" Then
sResult = sResult & GetDigit(Mid(sHundredNumber, 3))
sResult = sResult & " "
End If
End If
End If
GetHundreds = sResult
End Function
Function GetTens(ByVal sTensText As String) As String
Dim sResult As String
sResult = ""
If Left(sTensText, 1) = 1 Then
Select Case sTensText
Case "10": sResult = "Ten "
Case "11": sResult = "Eleven "
Case "12": sResult = "Twelve "
Case "13": sResult = "Thirteen "
Case "14": sResult = "Fourteen "
Case "15": sResult = "Fifteen "
Case "16": sResult = "Sixteen "
Case "17": sResult = "Seventeen"
Case "18": sResult = "Eighteen "
Case "19": sResult = "Nineteen "
Case Else
End Select
Else
Select Case Left(sTensText, 1)
Case "2": sResult = "Twenty "
Case "3": sResult = "Thirty "
Case "4": sResult = "Forty "
Case "5": sResult = "Fifty "
Case "6": sResult = "Sixty "
Case "7": sResult = "Seventy "
Case "8": sResult = "Eighty "
Case "9": sResult = "Ninety "
Case Else
End Select
sResult = sResult & GetDigit(Right(sTensText, 1))
End If
GetTens = sResult
End Function
Function GetDigit(ByVal sDigit As String) As String
Select Case sDigit
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
Public Function CMT(ByVal rgeCell As Range) As String
CMT = rgeCell.Comment.Text
End Function
Public Function NETWORKDAYSMISC(ByVal lStartDate As Long, _
ByVal lEndDate As Long, _
ByVal rgeHolidays As Range, _
ByVal rgeWorkDays As Range) As Long
'Returns the number of days between two dates using a defined list of
workdays.
'lStartDate The starting date.
'lEndDate The finishing date.
'rgeHolidays The dates to exclude from the working calendar, holidays and
floating days.
'rgeWorkdays The days of the week that you want to include.
Dim iweekdaycount As Integer
Dim bhasvalidworkday As Boolean
Dim bisvalidworkday As Boolean
Dim lnewdate As Long
Dim arholidays() As Long
Dim iholidaycount As Integer
Dim iarrayno As Integer
Dim ldaycount As Long
Call Application.Volatile(True)
If lStartDate = lEndDate Then NETWORKDAYSMISC = 0
If lStartDate = lEndDate Then Exit Function
bhasvalidworkday = False
For iweekdaycount = 1 To 7 Step 1
If rgeWorkDays.Item(iweekdaycount).Text <> "" Then
bhasvalidworkday = True
Exit For
End If
Next iweekdaycount
If bhasvalidworkday = False Then Call MsgBox("The rgeWorkDays parameter
is incorrect")
If bhasvalidworkday = False Then Exit Function
ReDim arholidays(rgeHolidays.Count)
For iholidaycount = 1 To rgeHolidays.Count
If rgeHolidays.Item(iholidaycount).Value <> "" Then
arholidays(iholidaycount) = rgeHolidays.Item(iholidaycount).Value
Else
Exit For
End If
Next iholidaycount
ReDim Preserve arholidays(iholidaycount - 1)
lnewdate = lStartDate
ldaycount = 0
Do Until lnewdate = lEndDate
bisvalidworkday = True
If lStartDate < lEndDate Then lnewdate = lnewdate + 1
If lStartDate > lEndDate Then lnewdate = lnewdate - 1
If rgeWorkDays.Item(VBA.Weekday(lnewdate)).Text <> "" Then
For iarrayno = 1 To UBound(arholidays)
If lnewdate = arholidays(iarrayno) Then
bisvalidworkday = False
Exit For
End If
Next iarrayno
If bisvalidworkday = True Then
If (lStartDate - lEndDate) < 0 Then ldaycount = ldaycount + 1
If (lStartDate - lEndDate) > 0 Then ldaycount = ldaycount - 1
End If
End If
Loop
NETWORKDAYSMISC = ldaycount
End Function
