Results 1 to 1 of 1

Thread:

Hybrid View

Previous Post Previous Post   Next Post Next Post
  1. #1
    Registered User
    Join Date: Oct:2003
    Posts: 1,861

    :
    , ( ) Excel 2003/Win7-32, , Office 2016/Win10-64. . , , ToWords .
    :
    Code:
    Attribute VB_Name = "Module1"
    '         VBA  Microsoft Excel
    ' Copyright (c) 2012 Unicontsoft (wqweto@gmail.com)
    '
    ' 
    '
    '     (  ),            ( 
    ' )    ( ).
    '
    ' 
    '
    '  VBA  Excel  Alt+F11          VBAProject   
    '  (Module1).    ( https://gist.github.com/4118581)  Module1   VBA
    '   .
    '
    ' 
    '
    '  ,           :
    '
    ' = ToWords(123)
    '
    '        (   ) 
    '
    ' = ToWord(A1)
    '
    '      A1     .
    '
    '      dblValue e 999 .
    '
    ' = ToWords(167.42) ->     .  42 .
    ' = ToWords(-12341235) ->         
    '    .  0 .
    ' = ToWords(341.6, "|", "F") ->       60 
    '
    '=====================================================================================================================
     
    Public Function ToWords(ByVal dblValue As Double, Optional Measure As Variant, Optional Gender As String) As String
    Dim vDigits As Variant
    Dim vGenderDigits As Variant
    Dim vValue As Variant
    Dim lIdx As Long
    Dim lDigit As Long
    '--- init digits (incl. gender ones)
    vDigits = Split("         ")
    vGenderDigits = vDigits
    Select Case Gender
    Case vbNullString, "M"
    vGenderDigits(1) = ""
    vGenderDigits(2) = ""
    Case "F"
    vGenderDigits(1) = ""
    End Select
    '--- split input value on decimal point and pad w/ zeroes
    vValue = Mid$(Format(0, "0.0"), 2, 1)
    vValue = Split(Format(Abs(dblValue), "0.00##"), vValue)
    vValue(0) = Right$(String(18, "0") & vValue(0), 18)
    '--- loop input digits from right to left
    For lIdx = 1 To Len(vValue(0))
    If lIdx <= 3 Then
    lDigit = Mid$(vValue(0), Len(vValue(0)) - lIdx + 1, 1)
    Else
    lDigit = Mid$(vValue(0), Len(vValue(0)) - lIdx - 1, 3)
    lIdx = lIdx + 2
    End If
    If lDigit <> 0 Then
    '--- separate by space (first time prepend "" too)
    If LenB(ToWords) <> 0 And (lIdx <> 2 Or lDigit <> 1) Then
    If InStr(ToWords, "  ") = 0 Then
    ToWords = "  " & ToWords
    Else
    ToWords = " " & ToWords
    End If
    End If
    Select Case lIdx
    Case 1
    ToWords = vGenderDigits(lDigit) & ToWords
    Case 2
    If lDigit = 1 Then
    '--- 11 to 19 special wordforms
    If LenB(ToWords) <> 0 Then
    ToWords = Replace(LTrim$(ToWords), vGenderDigits(1), "")
    ToWords = Replace(ToWords, vGenderDigits(2), "") & ""
    Else
    ToWords = ""
    End If
    Else
    ToWords = IIf(lDigit = 2, "", vDigits(lDigit)) & "" & ToWords
    End If
    Case 3
    '--- hundreds have special suffixes for 2 and 3
    Select Case lDigit
    Case 1
    ToWords = "" & ToWords
    Case 2, 3
    ToWords = vDigits(lDigit) & "" & ToWords
    Case Else
    ToWords = vDigits(lDigit) & "" & ToWords
    End Select
    Case 6
    '--- thousands are in feminine gender
    Select Case lDigit
    Case 1
    ToWords = "" & ToWords
    Case Else
    ToWords = ToWords(lDigit, vbNullString, Gender:="F") & " " & ToWords
    End Select
    Case 9, 12, 15
    '--- no special cases for bigger values
    ToWords = ToWords(lDigit, vbNullString) & " " & Split("   ")((lIdx - 9) \ 3) _
    & IIf(lDigit <> 1, "", vbNullString) & ToWords
    End Select
    End If
    Next
    '--- handle zero and negative values
    If LenB(ToWords) = 0 Then
    ToWords = vDigits(0)
    ElseIf dblValue < 0 Then
    ToWords = " " & ToWords
    End If
    '--- apply measure (use vbNullString for none)
    If IsMissing(Measure) Then
    Measure = ".|."
    End If
    If LenB(Measure) <> 0 Then
    ToWords = ToWords & " " & Split(Measure, "|")(0) & "  " & Val(vValue(1))
    If InStr(Measure, "|") > 0 Then
    ToWords = ToWords & " " & Split(Measure, "|")(1)
    End If
    ToWords = UCase$(Left$(ToWords, 1)) & Mid$(ToWords, 2)
    End If
    End Function
    Win Locale:Bulgarian - .
    , VBA Excel 2016/Win10-64 Excel . Win7-32, 2003 2016 Excel. Win7-32 Excel , - . , Excel ASCII, UTF8 ( 1251 - ), Win10-64 + Excel 2016.

    EDIT: , .
    Last edited by Jonata; 7th November 2018 at 15:56.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  

Copyright © 1999-2011 . .
iskamPC.com | mobility.BG | Bloody's Techblog | | 3D Vision Blog |