Mahfuza Anika Era

Dear NURIT,
Thank you so much for your comment. I have changed the date format to United States format in the code. You have to change the VBA code in the subroutine named Private Sub Create_Calender(). Following is the code for your required date format.

Private Sub Create_Calender()
For i = 1 To 42

If i < Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value)) Then
Controls("C" & (i)).Caption = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "d")

Controls("C" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "m/d/yyyy")

ElseIf i >= Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value)) Then
Controls("C" & (i)).Caption = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "d")

Controls("C" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "m/d/yyyy")
End If

If Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "mmmm") = ((Month_Box.Value)) Then
If Controls("C" & (i)).BackColor <> &HFFFFFF Then Controls("C" & (i)).BackColor = &HFFFFFF
Controls("C" & (i)).Font.Bold = True

If Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
((Month_Box.Value) & "/1/" & (Year_Box.Value))), "m/d/yyyy") = Format(This_Day, "m/d/yy") Then Controls("C" & (i)).SetFocus
Else
If Controls("C" & (i)).BackColor <> &H80000016 Then Controls("C" & (i)).BackColor = &H8000000F
Controls("C" & (i)).Font.Bold = False
End If

Next
End Sub 

Here is the screenshot of the new code. I have marked the changes for your better understanding.

Regards
Mahfuza Anika Era
ExcelDemy

Dear Salad,
Thanks for your question. Here is the VBA code that will give you your mentioned output.

Function NumberToWords(ByVal MyNumber)
    Dim TempStr As String
    Dim DecimalPlace As Integer
    Dim Count As Integer
    Dim DecimalSeparator As String
    Dim UnitName As String
    Dim SubUnitName As String
    Dim SubUnitValue As String
    Dim DecimalName As String
    Dim WholeNumberPart As String
    Dim DecimalPart As String

    DecimalSeparator = "point"
    UnitName = "Dollars"
    SubUnitName = "Cents"
    SubUnitValue = " "
    DecimalName = "Zero"

    MyNumber = Trim(Str(MyNumber))

    DecimalPlace = InStr(MyNumber, ".")

    If DecimalPlace > 0 Then
        DecimalPart = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2))
        MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
    End If

    Count = 1
    Do While MyNumber <> ""
        TempStr = GetHundreds(Right(MyNumber, 3))
        If TempStr <> "" Then
            WholeNumberPart = TempStr & GetUnits(Count) & WholeNumberPart
        End If
        If Len(MyNumber) > 3 Then
            MyNumber = Left(MyNumber, Len(MyNumber) - 3)
        Else
            MyNumber = ""
        End If
        Count = Count + 1
    Loop

    NumberToWords = WholeNumberPart & IIf(DecimalPart <> "", " and " & DecimalSeparator & " " & DecimalPart & " " & SubUnitName & " " & SubUnitValue, "")
End Function

Function GetUnits(ByVal Count)
    Select Case Count
        Case 1
            GetUnits = ""
        Case 2
            GetUnits = " Thousand"
        Case 3
            GetUnits = " Million"
        Case 4
            GetUnits = " Billion"
        Case 5
            GetUnits = " Trillion"
        Case Else
            GetUnits = ""
    End Select
End Function

Function GetHundreds(ByVal MyNumber)
    Dim Result As String
    If Val(MyNumber) = 0 Then Exit Function
    MyNumber = Right("000" & MyNumber, 3)
    If Mid(MyNumber, 1, 1) <> "0" Then
        Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
    End If
    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

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

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
End If

Following is the output after using the code.

Regards
Mahfuza Anika Era
ExcelDemy

Dear Stuart,
I am glad that you find this article informative. Thank you for your query. The VBA code which I have inserted in step 4 is in Sheet1 under Microsoft Excel Objects Section.

Mahfuza Anika Era
ExcelDemy

Dear Yosh,
I assume, this question is same as the previous one. You can follow the steps I have given in the previous reply. If you still have any confusion, please leave a comment describing your problem. Thank you!
Mahfuza Anika Era
ExcelDemy

Dear Max,
Thank you for your query. Changing the currency is not the reason behind the incorrect output of the module 2 code. Actually, the code is not working for the last 3 digits of the whole number part. Here is the modified code of module 1 that may help you. This will give the correct result hopefully.

Function number_converting_into_currency(ByVal MyNumber)
Dim x_string As String
Dim whole_num As Integer
Dim x_string_pnt
Dim x_string_Num
Dim x_pnt As String
Dim x_numb As String
Dim x_P() As Variant
Dim x_DP
Dim x_cnt As Integer
Dim x_output, x_T As String
Dim x_my_len As Integer
On Error Resume Next
x_P = Array("", "Thousand ", "Million ", "Billion ", "Trillion ", " ", " ", " ", " ")
x_numb = Trim(Str(MyNumber))
x_DP = InStr(x_numb, ".")
x_pnt = ""
x_string_Num = ""
If x_DP > 0 Then
x_pnt = " "
x_string = Mid(x_numb, x_DP + 1)
x_string_pnt = Left(x_string, Len(x_numb) - x_DP)
For whole_num = 1 To Len(x_string_pnt)
x_string = Mid(x_string_pnt, whole_num, 1)
x_pnt = x_pnt & get_digit(x_string) & " "
Next whole_num
x_numb = Trim(Left(x_numb, x_DP - 1))
End If
x_cnt = 0
x_output = ""
x_T = ""
x_my_len = 0
x_my_len = Int(Len(Str(x_numb)) / 3)
If (Len(Str(x_numb)) Mod 3) = 0 Then x_my_len = x_my_len - 1
Do While x_numb <> ""
If x_my_len = x_cnt Then
x_T = get_hundred_digit(Right(x_numb, 3), False)
Else
If x_cnt = 0 Then
x_T = get_hundred_digit(Right(x_numb, 3), True)
Else
x_T = get_hundred_digit(Right(x_numb, 3), False)
End If
End If
If x_T <> "" Then
x_output = x_T & x_P(x_cnt) & x_output
End If
If Len(x_numb) > 3 Then
x_numb = Left(x_numb, Len(x_numb) - 3)
Else
x_numb = ""
End If
x_cnt = x_cnt + 1
Loop
If x_DP > 0 Then
x_output = x_output & "dollars" & x_pnt & "Cents"
Else
x_output = x_output & "dollars"
End If
number_converting_into_currency = x_output
End Function
Function get_hundred_digit(xHDgt, y_b As Boolean)
Dim x_R_str As String
Dim x_string_Num As String
Dim x_string As String
Dim y_I As Integer
Dim y_bb As Boolean
x_string_Num = xHDgt
x_R_str = ""
On Error Resume Next
y_bb = True
If Val(x_string_Num) = 0 Then Exit Function
x_string_Num = Right("000" & x_string_Num, 3)
x_string = Mid(x_string_Num, 1, 1)
If x_string <> "0" Then
x_R_str = get_digit(Mid(x_string_Num, 1, 1)) & "Hundred "
Else
If y_b Then
x_R_str = "and "
y_bb = False
Else
x_R_str = " "
y_bb = False
End If
End If
If Mid(x_string_Num, 2, 2) <> "00" Then
x_R_str = x_R_str & get_ten_digit(Mid(x_string_Num, 2, 2), y_bb)
End If
get_hundred_digit = x_R_str
End Function
Function get_ten_digit(x_TDgt, y_b As Boolean)
Dim x_string As String
Dim y_I As Integer
Dim x_array_1() As Variant
Dim x_array_2() As Variant
Dim x_T As Boolean
x_array_1 = Array("Ten ", "Eleven ", "Twelve ", "Thirteen ", "Fourteen ", "Fifteen ", "Sixteen ", "Seventeen ", "Eighteen ", "Nineteen ")
x_array_2 = Array("", "", "Twenty ", "Thirty ", "Forty ", "Fifty ", "Sixty ", "Seventy ", "Eighty ", "Ninety ")
x_string = ""
x_T = True
On Error Resume Next
If Val(Left(x_TDgt, 1)) = 1 Then
y_I = Val(Right(x_TDgt, 1))
If y_b Then x_string = "and "
x_string = x_string & x_array_1(y_I)
Else
y_I = Val(Left(x_TDgt, 1))
If Val(Left(x_TDgt, 1)) > 1 Then
If y_b Then x_string = "and "
x_string = x_string & x_array_2(Val(Left(x_TDgt, 1)))
x_T = False
End If
If x_string = "" Then
If y_b Then
x_string = " "
End If
End If
If Right(x_TDgt, 1) <> "0" Then
x_string = x_string & get_digit(Right(x_TDgt, 1))
End If
End If
get_ten_digit = x_string
End Function
Function get_digit(xDgt)
Dim x_string As String
Dim x_array_1() As Variant
x_array_1 = Array("Zero ", "One ", "Two ", "Three ", "Four ", "Five ", "Six ", "Seven ", "Eight ", "Nine ")
x_string = ""
On Error Resume Next
x_string = x_array_1(Val(xDgt))
get_digit = x_string
End Function

Copy the code in your module and Run the code.

I hope you have got your problem solved. Thank you.
Regards
Mahfuza Anika Era
ExcelDemy