MyTetra Share
Делитесь знаниями!
функцию прописи денежных рублевых сумм
16.03.2019
23:43
Раздел: !Закладки - VBA - Разобрать

На скорую руку набросал функцию прописи денежных рублевых сумм

Функция VBA


Visual BasicВыделить код

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
Function NumToText(ByVal Num As Double) As String
 ' Возвращает числовое значение прописью в виде текста
 ' Ххххх ххххх хххххх рублей YY копееек
Dim Num_, Num0, Num1, Num2, Num3, Num4, Num5, Num6, Num7, Num8 As Integer
Dim Dig(1 To 19) As String  ' цифры и числа от 1 до 19
Dim Dec(1 To 10) As String  ' десятки
Dim Sot(1 To 9) As String   ' сотни
Dim strText1, strText2 As String
Dim L As Integer
Dig(1) = "один"
Dig(2) = "два"
Dig(3) = "три"
Dig(4) = "четыре"
Dig(5) = "пять"
Dig(6) = "шесть"
Dig(7) = "семь"
Dig(8) = "восемь"
Dig(9) = "девять"
Dig(10) = "десять"
Dig(11) = "одиннадцать"
Dig(12) = "двенадцать"
Dig(13) = "тринадцать"
Dig(14) = "четырнадцать"
Dig(15) = "пятнадцать"
Dig(16) = "шестнадцать"
Dig(17) = "семнадцать"
Dig(18) = "восемнадцать"
Dig(19) = "девятнадцать"
 
Dec(1) = "десять"
Dec(2) = "двадцать"
Dec(3) = "тридцать"
Dec(4) = "сорок"
Dec(5) = "пятьдесят"
Dec(6) = "шестьдесят"
Dec(7) = "семьдесят"
Dec(8) = "восемьдесят"
Dec(9) = "девяносто"
 
Sot(1) = "сто"
Sot(2) = "двести"
Sot(3) = "триста"
Sot(4) = "четыреста"
Sot(5) = "пятьсот"
Sot(6) = "шестьсот"
Sot(7) = "семьсот"
Sot(8) = "восемьсот"
Sot(9) = "девятьсот"
 
Num8 = Fix(Num / 100000000)
Num7 = Fix((Num - Num8 * 100000000) / 10000000)
Num6 = Fix((Num - Num8 * 100000000 - Num7 * 10000000) / 1000000)
Num5 = Fix((Num - Num8 * 100000000 - Num7 * 10000000 - Num6 * 1000000) / 100000)
Num4 = Fix((Num - Num8 * 100000000 - Num7 * 10000000 - Num6 * 1000000 - Num5 * 100000) / 10000)
Num3 = Fix((Num - Num8 * 100000000 - Num7 * 10000000 - Num6 * 1000000 - Num5 * 100000 - Num4 * 10000) / 1000)
Num2 = Fix((Num - Num8 * 100000000 - Num7 * 10000000 - Num6 * 1000000 - Num5 * 100000 - Num4 * 10000 - Num3 * 1000) / 100)
Num1 = Fix((Num - Num8 * 100000000 - Num7 * 10000000 - Num6 * 1000000 - Num5 * 100000 - Num4 * 10000 - Num3 * 1000 - Num2 * 100) / 10)
Num0 = Fix((Num - Num8 * 100000000 - Num7 * 10000000 - Num6 * 1000000 - Num5 * 100000 - Num4 * 10000 - Num3 * 1000 - Num2 * 100 - Num1 * 10))
Num_ = Fix((Num - Fix(Num)) * 100)
 
NumToText = ""
Select Case Num8    ' сотни миллионов
   Case Is > 9
        NumToText = "число > 999 999 999.99"
   Case Is > 0
        NumToText = NumToText & Sot(Num8)
End Select
 
Select Case Num7    ' десятки миллионов
   Case Is > 1
        NumToText = NumToText & " " & Dec(Num7)
   Case Is = 1
        If Num6 = 0 Then
            NumToText = NumToText & " десять миллионов "
        Else
            NumToText = NumToText & " " & Dig(Num7 * 10 + Num6) & " миллионов "
        End If
        GoTo Tysachi
End Select
                    ' единицы миллионов
If Num6 > 0 And Num7 <> 1 Then NumToText = NumToText & " " & Dig(Num6)
 
If NumToText <> "" Then
    Select Case Num6
        Case Is > 4
            NumToText = NumToText & " миллионов "
        Case Is > 1
            NumToText = NumToText & " миллиона "
        Case Is = 1
            NumToText = NumToText & " миллион "
        Case Is = 0
            NumToText = NumToText & " миллионов "
    End Select
End If
 
                    ' сотни тысяч
Tysachi:
If Num5 > 0 Then NumToText = NumToText & " " & Sot(Num5)
 
Select Case Num4    ' десятки тысяч
   Case Is > 1
        NumToText = NumToText & " " & Dec(Num4)
   Case Is = 1
        If Num3 = 0 Then
            NumToText = NumToText & " десять тысяч "
        Else
            NumToText = NumToText & " " & Dig(Num4 * 10 + Num3) & " тысяч "
        End If
        GoTo Rubl
End Select
                    ' единицы тысяч
Select Case Num3
    Case Is = 1
        NumToText = NumToText & " одна"
    Case Is = 2
        NumToText = NumToText & " две"
    Case Is > 2
        NumToText = NumToText & " " & Dig(Num3)
End Select
 
If Num5 <> 0 Or Num4 <> 0 Or Num3 <> 0 Then
    Select Case Num3
        Case Is > 4
            NumToText = NumToText & " тысяч "
        Case Is > 1
            NumToText = NumToText & " тысячи "
        Case Is = 1
            NumToText = NumToText & " тысяча "
        Case Else
            NumToText = NumToText & " тысяч "
    End Select
End If
                    ' сотни рублей
Rubl:
If Num2 > 0 Then NumToText = NumToText & Sot(Num2)
 
Select Case Num1    ' десятки рублей
   Case Is > 1
        NumToText = NumToText & " " & Dec(Num1)
   Case Is = 1
        If Num0 = 0 Then
            NumToText = NumToText & " десять рублей"
        Else
            NumToText = NumToText & " " & Dig(Num1 * 10 + Num0) & " рублей"
        End If
        GoTo Kopeika
End Select
                    ' единицы рублей
If Num0 > 0 And Num1 <> 1 Then NumToText = NumToText & " " & Dig(Num0)
 
Select Case Num0
   Case Is > 4
        NumToText = NumToText & " рублей "
   Case Is > 1
        NumToText = NumToText & " рубля "
   Case Is = 1
        NumToText = NumToText & " рубль "
   Case Is = 0
        NumToText = NumToText & " рублей "
End Select
Kopeika:
                    ' копейки
NumToText = NumToText & " " & Format(Num_, "00")
Select Case Num_
    Case Is > 4
        NumToText = NumToText & " копеек"
    Case Is > 1
        NumToText = NumToText & " копейки"
    Case Is = 1
        NumToText = NumToText & " копейка"
    Case Is = 0
        NumToText = NumToText & " копеек"
End Select
            ' заглавная первая буква
NumToText = LTrim(NumToText)
L = Len(NumToText)
strText1 = Left(NumToText, 1)
strText2 = Right(NumToText, L - 1)
NumToText = UCase(strText1) & strText2
End Function

Последний раз редактировалось Ameli; 02.04.2012 в 10:49.

Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования