'Date to Words by Learn More Copy Below Code Function DateToWords(ByVal xRgVal As Date) As String 'UpdatebyLearnmorepro Dim xYear As String Dim Hundreds As String Dim Decades As String Dim xTensArr As Variant Dim xOrdArr As Variant Dim xCardArr As Variant xOrdArr = Array("First", "Second", "Third", _ "Fourth", "Fifth", "Sixth", _ "Seventh", "Eighth", "Nineth", _ "Tenth", "Eleventh", "Twelfth", _ "Thirteenth", "Fourteenth", _ "Fifteenth", "Sixteenth", _ "Seventeenth", "Eighteenth", _ "Nineteenth", "Twentieth", _ "Twenty-first", "Twenty-second", _ "Twenty-third", "Twenty-fourth", _ "Twenty-fifth", "Twenty-sixth", _ "Twenty-seventh", "Twenty-eighth", _ "Twenty-nineth", "Thirtieth", _ "Thirty-first") xCardArr = Array("", "One", "Two", "Three", "Four", _ "Five", "Six", "Seven", "Eight", "Nine", "Ten", "Eleven", "Twelve", "Thirteen", "Fourteen", "Fifteen", "Sixteen", "Seventeen", "Eighteen", "Nineteen") xTensArr = Array("Twenty", "Thirty", "Forty", "Fifty", "Sixty", "Seventy", "Eighty", "Ninety") xYear = CStr(Year(xRgVal)) Decades = Mid$(xYear, 3) If CInt(Decades) < 20 Then Decades = xCardArr(CInt(Decades)) Else Decades = xTensArr(CInt(Left$(Decades, 1)) - 2) & " " & _ xCardArr(CInt(Right$(Decades, 1))) End If Hundreds = Mid$(xYear, 2, 1) If CInt(Hundreds) Then Hundreds = xCardArr(CInt(Hundreds)) & " Hundred " Else Hundreds = "" End If DateToWords = xOrdArr(Day(xRgVal) - 1) & _ Format$(xRgVal, " mmmm ") & _ xCardArr(CInt(Left$(xYear, 1))) & _ " Thousand " & Hundreds & Decades End Function