liczba_slowa.txt

Option Explicit
Sub licz1()
' przykład zastosowania
Dim x1 As String	' liczba na slowa

' funkcja "Liczba_slowa" jest wywolywana z parametrm czyli z liczba,
'  a  zwracana jest liczba w postaci stringa

x1 = Liczba_slowa(1267.5)

MsgBox x1

End Sub

Function Liczba_slowa(wej_liczba As Double) As Variant
'===================================================================
'=   Procedure: Liczba_slowa                                       =
'=        Type: Function                                           =
'=                                                                 =
'=     Opis: zamiana liczby na jej reprezentację słowną          =
'=  Parametr: wej_liczba - Double                                 =

Application.Volatile
'zmienne do przechowywania części składowych argumentu dblAmount,
'tysięcy złotych, złotych i groszy.
Dim intST As Integer, intDT As Integer, intTY As Integer
Dim intSZ As Integer, intDZ As Integer, intZL As Integer
Dim intDG As Integer, intGR As Integer

'zmienne pomocne przy określaniu prawidłowej formy gramatycznej
'słów : tysiąc, złoty, grosz.
Dim intT As Integer, intZ As Integer, intG As Integer

'zmienne te przechowują odpowiedni element tekstowy ze zdefinowanych
'niżej tablic.
Dim varSETKI As Variant, varDZIESIATKI As Variant, varNASTKI As Variant
Dim varJEDNOSTKI As Variant, varTYSIACE As Variant, varZLOTE As Variant
Dim varGROSZE As Variant
Dim strSLOWNIE As String, strAMOUNT As String

'jeżeli wartość absolutna liczby przekracza 999.999,99 funkcja zwraca
'wartość błędu #N/A.

If Abs(wej_liczba) > 999999.99 Then
  Liczba_slowa = CVErr(xlErrNA)
  Exit Function
End If

'zdefiniowanie tablic zawierających wartości słowne odpowiadające
'elementom wartości
varSETKI = Array("", "sto ", "dwieście ", "trzysta ", "czterysta ", _
"pięćset ", "sześćset ", "siedemset ", "osiemset ", "dziewięćset ")

varDZIESIATKI = Array("", "dziesięć ", "dwadzieścia ", "trzydzieści ", _
"czterdzieści ", "pięćdziesiąt ", "sześćdziesiąt ", "siedemdziesiąt ", _
"osiemdziesiąt ", "dziewięćdziesiąt ")

varNASTKI = Array("", "jedenaście ", "dwanaście ", "trzynaście ", _
"czternaście ", "piętnaście ", "szesnaście ", "siedemnaście ", _
"osiemnaście ", "dziewiętnaście ")

varJEDNOSTKI = Array("", "jeden ", "dwa ", "trzy ", "cztery ", _
"pięć ", "sześć ", "siedem ", "osiem ", "dziewięć ")

varTYSIACE = Array("", "tysiąc ", "tysiące ", "tysięcy ")
varZLOTE = Array("zero, ", ", ", ", ", ", ")
varGROSZE = Array("zero", " ", " ", " ")

'zamiana liczby na tekst w formacie '00000000'.
strAMOUNT = Format(Abs(Application.WorksheetFunction.Round(wej_liczba, 2) * 100), "00000000")

'rozbijamy liczbe na części składowe.
'Tysiace
intST = Val(Mid(strAMOUNT, 1, 1))
intDT = Val(Mid(strAMOUNT, 2, 1))
intTY = Val(Mid(strAMOUNT, 3, 1))
'Zlote
intSZ = Val(Mid(strAMOUNT, 4, 1))
intDZ = Val(Mid(strAMOUNT, 5, 1))
intZL = Val(Mid(strAMOUNT, 6, 1))
'Grosze
intDG = Val(Mid(strAMOUNT, 7, 1))
intGR = Val(Mid(strAMOUNT, 8, 1))

strSLOWNIE = varSETKI(intST)

'kod poniżej służy umożliwia zwrócenie prawidłowej formy
'gramatycznej liczebników.
If intDT = 1 And intTY <> 0 Then
  strSLOWNIE = strSLOWNIE & varNASTKI(intTY)
Else
  strSLOWNIE = strSLOWNIE & varDZIESIATKI(intDT) & varJEDNOSTKI(intTY)
End If

'Tysiące
If (intST + intDT + intTY) = 0 Then
  intT = 0
ElseIf (intST + intDT) = 0 And intTY = 1 Then
  intT = 1
ElseIf (intTY = 2 Or intTY = 3 Or intTY = 4) And intDT <> 1 Then
  intT = 2
Else
  intT = 3
End If

strSLOWNIE = strSLOWNIE & varTYSIACE(intT) & varSETKI(intSZ)

'pojedyncze
If intDZ = 1 And intZL <> 0 Then
  strSLOWNIE = strSLOWNIE & varNASTKI(intZL)
Else
  strSLOWNIE = strSLOWNIE & varDZIESIATKI(intDZ) & varJEDNOSTKI(intZL)
End If

If (intST + intDT + intTY + intSZ + intDZ + intZL) = 0 Then
  intZ = 0
ElseIf (intSZ + intDZ = 0) And intZL = 1 Then
  intZ = 1
ElseIf (intZL = 2 Or intZL = 3 Or intZL = 4) And intDZ <> 1 Then
  intZ = 2
Else
  intZ = 3
End If

strSLOWNIE = strSLOWNIE & varZLOTE(intZ)

'0.1 dziesiatki
If intDG = 1 And intGR <> 0 Then
  strSLOWNIE = strSLOWNIE & varNASTKI(intGR)
Else
  strSLOWNIE = strSLOWNIE & varDZIESIATKI(intDG) & varJEDNOSTKI(intGR)
End If

If intDG + intGR = 0 Then
  intG = 0
ElseIf intDG = 0 And intGR = 1 Then
  intG = 1
ElseIf (intGR = 2 Or intGR = 3 Or intGR = 4) And intDG <> 1 Then
  intG = 2
Else
  intG = 3
End If

strSLOWNIE = strSLOWNIE & varGROSZE(intG)
Liczba_slowa = strSLOWNIE

End Function