Tworzymy makro dla programu Microsoft Excel

Dziś umieszczę makro do programu Microsoft Excel które umożliwia konwersja zapisu liczbowego na zapis słowny. Poniżej umieszczam kod całego makra oraz plik xla do ściągniecia. Życzę miłego analizowania kodu i jak zwykle czekam na informacje o błędach i ewentualne sugestie na przyszłość.

'skrypt sciagniety ze strony www.grzegorzsurowiec.pl
Option Compare Binary 'typ porownania stringów: binarny
Option Explicit 'wymusza deklaracje zmiennych
 
'deklaracja zmiennych
Private Male As Variant
Private Nascie As Variant
Private Duze As Variant
 
'tworzenie metody
'parametr 'l' kwota z akrusza w formacie Currency
 
Function Słownie(ByVal l As Currency) As String
 
 'definicja zmiennych
 Dim S, temp As String
 Dim zl As Currency
 Dim g, i, gr, pos, j, koncowka As Integer
 'zmienna trzyma grupy cyfr -
 'na razie 4: tysiące, miliony, miliardy, biliony
 Dim rozdziel(0 To 3) As Variant
 
 'tworzenie tablic
 Male = Array( _
 Array("", "jeden", "dwa", "trzy", "cztery", "pięć", "sześć", _
 "siedem", "osiem", "dziewięć"), _
 Array("", "", "dwadzieścia", "trzydzieści", "czterdzieści", _
 "pięćdziesiąt", "sześćdziesiąt", "siedemdziesiąt", _
 "osiemdziesiąt", "dziewięćdziesiąt"), _
 Array("", "sto", "dwieście", "trzysta", "czterysta", "pięćset", _
 "sześćset", "siedemset", "osiemset", "dziewięćset") _
 )
 
 Nascie = Array("dziesięć", "jedenaście", "dwanaście", "trzynaście", _
 "czternaście", "piętnaście", "szesnaście", "siedemnaście", _
 "osiemnaście", "dziewiętnaście")
 
 Duze = Array( _
 Array("tysiąc", "tysiące", "tysięcy"), _
 Array("milion", "miliony", "milionów"), _
 Array("miliard", "miliardy", "miliardów"), _
 Array("bilion", "biliony", "bilionów") _
 )
 
 l = WorksheetFunction.Round(l, 2)  'zaokraglamy do groszy
 zl = WorksheetFunction.Floor(l, 1) 'zapisuje czesc całkowitą
 gr = (l - zl) * 100 'zapisujemy grosze
 
 S = CStr(zl) 'zmieniamy kwotę na stringa
 
 'inicjalizacja zmiennych potrzebnych do obsługi pętli
 i = 0
 g = 0
 'inicjuj grupę
 rozdziel(g) = Array(-1, -1, -1)
 
 For pos = Len(S) - 1 To 0 Step -1
 
 'zapisujemy jeden znak do odpowiedniej pozycji w grupie
 rozdziel(g)(i) = CByte(Mid(S, pos + 1, 1))
 
 'tworzymy nową grupę cyfr
 If i = 2 And pos > 0 Then
 g = g + 1 'nowy id grupy
 i = -1 'przy nastepnej petli i = 0
 rozdziel(g) = Array(-1, -1, -1) 'inicjujemy nową grupę
 End If
 
 i = i + 1
 Next
 
 S = "" 'czyscimy zmienna S ktora będzie "zbierała" kwotę słownie
 
 For i = 0 To g
 
 temp = ""
 
 For j = 2 To 0 Step -1 'poruszamy się po grupie od końca
 
 'analizujemy tylko wartości różne od -1
 If rozdziel(i)(j) > -1 Then
 
 If j = 1 Then
 'sprawdzamy czy środkowa cyfra nie jest cyfrą 1
 'aby wywołać tablicę NASCIE
 If rozdziel(i)(j) = 1 Then
 temp = temp & Nascie(rozdziel(i)(0)) & " "
 'czyścimy pierwszą liczbę w grupie bo już nie jest potrzebna
 rozdziel(i)(0) = -1
 Else:
 If rozdziel(i)(j) > 0 Then temp = temp & Male(j)(rozdziel(i)(j)) & " "
 End If
 Else:
 If rozdziel(i)(j) > 0 Then temp = temp & Male(j)(rozdziel(i)(j)) & " "
 End If
 
 End If
 
 Next
 
 'ostatnia cyfra z tysiaca jest zdefiniowana
 If rozdziel(i)(2) > -1 Then
 If i + 1 <= g Then 'jest nastepna grupa cyfr
 'ustalamy koncówkę dla tablicy DUZE
 
 'analizujemy pierwszą cyfrę w kolejnej grupie
 Select Case CByte(rozdziel(i + 1)(0))
 Case 1: koncowka = 0
 Case 2, 3, 4: koncowka = 1
 Case Else: koncowka = 2
 End Select
 
 'analizujemy drugą cyfrę w kolejnej grupie
 If rozdziel(i + 1)(0) = 1 Then
 koncowka = 2
 End If
 
 'jeśli następna grupa nie jest pusta dodaj wartość z tablicy DUZE
 If rozdziel(i + 1)(0) > 0 Or rozdziel(i + 1)(1) > 0 Or _
 rozdziel(i + 1)(2) > 0 Then
 'if i==0
 S = Duze(i)(koncowka) & " " & temp & S
 Else: S = temp & S
 End If
 Else: S = temp & S
End If
 
 Else: S = temp & S
 End If
 
 Next
 
 'wyświetl liczbę słownie
 Słownie = Trim(S) & " " & Format(CDbl(gr), "00") & "/100"
End Function

Plik Słownie.zip

Ten wpis został opublikowany w kategorii Microsoft Office, VB i oznaczony tagami , , , . Dodaj zakładkę do bezpośredniego odnośnika.

Jedna odpowiedź na „Tworzymy makro dla programu Microsoft Excel

  1. Pingback: Opis instalacja makr w programie Microsoft Excel 2007 | Grzegorz Surowiec

Dodaj komentarz

Twój adres email nie zostanie opublikowany. Pola, których wypełnienie jest wymagane, są oznaczone symbolem *