Słownie z groszami w postaci ułamka

Opublikowany 27 kwietnia 2023 przez Dariusz Kolasa

Nowa wersja funkcji Slownie ma drugi parametr, który określa w jakiej postaci mają być grosze (zamiast True można wpisać 1 a zamiast False – 0)

Nawiasem mówiąc im nowszy WordPress tym gorszy do prowadzenia blogu programistycznego. Nie da się już użyć wtyczki do kolorowania kodu bez popsucia kodu 🙁
Wpisuje się to niestety w ogólny trend totalnego obniżania jakości i zarzucania użytkownika masą zbędnych i irytujących funkcji
Sytuację ratuje na szczęście wtyczka Classic Editor przywracająca starszą wersję edytora…

 
Option Explicit
 
Function Slownie(Kwota As Variant, UlamkoweGrosze As Boolean) As String
   '==================================
    ' UWAGA! Funkcja wymaga obu funkcji
    ' prywatnych zamieszczonych poniżej
    '==================================
 
    Const WERSJA As String = _
        "Funkcja Słownie v.1.03 (Akademia-VBA.pl)"
 
    Dim Opis(19) As String
    Dim DziesOpis(2 To 10) As String
    Dim SetOpis(1 To 9) As String
 
    Dim Zlotowki As String
    Dim Grosze As String
 
    Dim TrojkaZl As String
    Dim TrojkaTys As String
    Dim TrojkaMln As String
 
    Dim wynikGrosze As String
    Dim wynikZlote As String
    Dim Ujemna As Boolean
 
    On Error GoTo Obsluga
 
    'sprawdzenie czy puste
    If IsNull(Kwota) Or IsEmpty(Kwota) Then
        Slownie = "# Brak kwoty!"
        Exit Function
    End If
 
    'sprawdzenie czy liczba
    If Not IsNumeric(Kwota) Then
        Slownie = "# Nieprawidłowy typ wartości!"
        Exit Function
    End If
 
    'gdy ujemna
    If Kwota < 0 Then
        Ujemna = True
        Kwota = -Kwota
    End If
 
    'konwersja na stringi
    Zlotowki = CStr(Int(Kwota))
    Grosze = CStr(Kwota - Int(Kwota))
 
    'sprawdzenie, czy nie za duża, max 99 mln
    If Len(Zlotowki) > 9 Then
        Slownie = "# Kwota za duża, max 999 mln!"
        Exit Function
    End If
 
    'ewentualne zaokrąglenie do 2 msc po przecinku
    'tu drobna poprawka stąd wersja 1.01
    'było ...= CStr(Round(CDbl(Grosze) * 100, 2))
    If Len(Grosze) > 2 Then
        Grosze = CStr(Round(CDbl(Grosze), 2) * 100)
    End If
 
    'kod zasadniczy
    '==============
    Select Case Len(Zlotowki)
    Case 1 To 3
        wynikZlote = Trojka(Zlotowki) & _
            OpisRzeduWielkosci(CLng(Zlotowki), "zł", False)
    Case 4 To 6
        TrojkaZl = Right(Zlotowki, 3)
        TrojkaTys = Left(Zlotowki, Len(Zlotowki) - 3)
        wynikZlote = Trojka(TrojkaTys) & _
            OpisRzeduWielkosci(CLng(TrojkaTys), "tys", True) _
            & " " & Trojka(TrojkaZl) & _
            OpisRzeduWielkosci(CLng(TrojkaZl), "zł", True)
    Case 7 To 9
        TrojkaZl = Right(Zlotowki, 3)
        TrojkaTys = Mid(Zlotowki, Len(Zlotowki) - 5, 3)
        TrojkaMln = Left(Zlotowki, Len(Zlotowki) - 6)
        wynikZlote = Trojka(TrojkaMln) & _
            OpisRzeduWielkosci(CLng(TrojkaMln), "mln", True) _
            & " " & Trojka(TrojkaTys) & _
            OpisRzeduWielkosci(CLng(TrojkaTys), "tys", True) _
            & " " & Trojka(TrojkaZl) & _
            OpisRzeduWielkosci(CLng(TrojkaZl), "zł", True)
    End Select
 
    If UlamkoweGrosze Then
        wynikGrosze = Format(Grosze, "00") & "/100"
    Else
        wynikGrosze = Trojka(Grosze) & _
           OpisRzeduWielkosci(CLng(Grosze), "gr", False)
 
        If wynikGrosze = "" Then wynikGrosze = "zero groszy"
    End If
 
    If wynikZlote = "" Then wynikZlote = "zero złotych"
 
    Slownie = IIf(Ujemna, "minus ", "") & _
        Trim(wynikZlote & " " & wynikGrosze)
 
    Exit Function
 
Obsluga:
    MsgBox Err & " - " & Err.Description, vbCritical, WERSJA
 
End Function
 
Private Function OpisRzeduWielkosci( _
        Liczba As Long, RzadWielkosci As String, _
        WiekszeTysiac As Boolean) As String
 
    Dim JestZero As Boolean
    Dim DwieOstatnie As Long
    Dim Ostatnia As Long
 
    If Liczba = 0 Then
        If WiekszeTysiac Then
            If RzadWielkosci = "zł" Then
                OpisRzeduWielkosci = "złotych"
            End If
        Else
            OpisRzeduWielkosci = ""
        End If
        Exit Function
    End If
 
    DwieOstatnie = CLng(Right(CStr(Liczba), 2))
    Ostatnia = CLng(Right(CStr(Liczba), 1))
 
    Select Case RzadWielkosci
    Case "gr"
        Select Case DwieOstatnie
        Case 0, 5 To 19
            OpisRzeduWielkosci = " groszy"
        Case 1
            OpisRzeduWielkosci = " grosz"
        Case 2 To 4
            OpisRzeduWielkosci = " grosze"
        Case Is > 19
            Select Case Ostatnia
            Case 0, 1, Is > 4
                OpisRzeduWielkosci = " groszy"
            Case 2 To 4
                OpisRzeduWielkosci = " grosze"
            End Select
        End Select
    Case "zł"
        Select Case DwieOstatnie
        Case 0, 5 To 19
            OpisRzeduWielkosci = " złotych"
        Case 1
            OpisRzeduWielkosci = " złoty"
        Case 2 To 4
            OpisRzeduWielkosci = " złote"
        Case Is > 19
            Select Case Ostatnia
            Case 0, 1, Is > 4
                OpisRzeduWielkosci = " złotych"
            Case 2 To 4
                OpisRzeduWielkosci = " złote"
            End Select
        End Select
    Case "tys"
        Select Case DwieOstatnie
        Case 0, 5 To 19
            OpisRzeduWielkosci = " tysięcy"
        Case 1
            OpisRzeduWielkosci = " tysiąc"
        Case 2 To 4
            OpisRzeduWielkosci = " tysiące"
        Case Is > 19
            Select Case Ostatnia
            Case 0, 1, Is > 4
                OpisRzeduWielkosci = " tysięcy"
            Case 2 To 4
                OpisRzeduWielkosci = " tysiące"
            End Select
        End Select
    Case "mln"
        Select Case DwieOstatnie
        Case 0, 5 To 19
            OpisRzeduWielkosci = " milionów"
        Case 1
            OpisRzeduWielkosci = " milion"
        Case 2 To 4
            OpisRzeduWielkosci = " miliony"
        Case Is > 19
            Select Case Ostatnia
            Case 0, 1, Is > 4
                OpisRzeduWielkosci = " milionów"
            Case 2 To 4
                OpisRzeduWielkosci = " miliony"
            End Select
        End Select
    End Select
End Function
 
Private Function Trojka(strLiczba As String) As String
    Dim lngLiczba As Long
    Dim lngOstatnia As Long
    Dim lngDwieOstatnie As Long
 
    Dim Opis(19) As String
    Dim DziesOpis(10) As String
    Dim SetOpis(9) As String
 
    If CLng(strLiczba) = 0 Then
        Trojka = ""
        Exit Function
    End If
 
    Opis(0) = "zero"
    Opis(1) = "jeden"
    Opis(2) = "dwa"
    Opis(3) = "trzy"
    Opis(4) = "cztery"
    Opis(5) = "pięć"
    Opis(6) = "sześć"
    Opis(7) = "siedem"
    Opis(8) = "osiem"
    Opis(9) = "dziewięć"
    Opis(10) = "dziesięć"
    Opis(11) = "jedenaście"
    Opis(12) = "dwanaście"
    Opis(13) = "trzynaście"
    Opis(14) = "czternaście"
    Opis(15) = "piętnaście"
    Opis(16) = "szesnaście"
    Opis(17) = "siedemnaście"
    Opis(18) = "osiemnaście"
    Opis(19) = "dziewiętnaście"
 
    DziesOpis(0) = "zero"
    DziesOpis(1) = "dziesięć"
    DziesOpis(2) = "dwadzieścia"
    DziesOpis(3) = "trzydzieści"
    DziesOpis(4) = "czterdzieści"
    DziesOpis(5) = "pięćdziesiąt"
    DziesOpis(6) = "sześćdziesiąt"
    DziesOpis(7) = "siedemdziesiąt"
    DziesOpis(8) = "osiemdziesiąt"
    DziesOpis(9) = "dziewięćdziesiąt"
 
    SetOpis(0) = "zero"
    SetOpis(1) = "sto"
    SetOpis(2) = "dwieście"
    SetOpis(3) = "trzysta"
    SetOpis(4) = "czterysta"
    SetOpis(5) = "pięćset"
    SetOpis(6) = "sześćset"
    SetOpis(7) = "siedemset"
    SetOpis(8) = "osiemset"
    SetOpis(9) = "dziewięćset"
 
    lngLiczba = CLng(strLiczba)
 
    'tu policzymy ostatnią
    lngOstatnia = CLng(Right(strLiczba, 1))
 
    Select Case lngLiczba
    Case Is < 20
        Trojka = Opis(lngLiczba)
    Case Is < 100
        If lngLiczba Mod 10 = 0 Then
            Trojka = DziesOpis(lngLiczba / 10)
        Else
            Trojka = DziesOpis((lngLiczba - lngOstatnia) / 10) _
                & " " & Opis(lngOstatnia)
        End If
    Case Else 'trzycyfrowa
        If lngLiczba Mod 100 = 0 Then
            Trojka = SetOpis(lngLiczba / 100)
        Else
            'tu policzymy dwie ostatnie
            lngDwieOstatnie = CLng(Right(strLiczba, 2))
 
            If lngLiczba Mod 10 = 0 Then
                Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _
                    & " " & DziesOpis(lngDwieOstatnie / 10)
            Else
                If lngDwieOstatnie < 20 Then
                    Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _
                        & " " & Opis(lngDwieOstatnie)
                Else
                    Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _
                        & " " & DziesOpis((lngDwieOstatnie - lngOstatnia) / 10) _
                        & " " & Opis(lngOstatnia)
                End If
            End If
        End If
    End Select
End Function

Option Explicit Function Slownie(Kwota As Variant, UlamkoweGrosze As Boolean) As String '================================== ' UWAGA! Funkcja wymaga obu funkcji ' prywatnych zamieszczonych poniżej '================================== Const WERSJA As String = _ "Funkcja Słownie v.1.03 (Akademia-VBA.pl)" Dim Opis(19) As String Dim DziesOpis(2 To 10) As String Dim SetOpis(1 To 9) As String Dim Zlotowki As String Dim Grosze As String Dim TrojkaZl As String Dim TrojkaTys As String Dim TrojkaMln As String Dim wynikGrosze As String Dim wynikZlote As String Dim Ujemna As Boolean On Error GoTo Obsluga 'sprawdzenie czy puste If IsNull(Kwota) Or IsEmpty(Kwota) Then Slownie = "# Brak kwoty!" Exit Function End If 'sprawdzenie czy liczba If Not IsNumeric(Kwota) Then Slownie = "# Nieprawidłowy typ wartości!" Exit Function End If 'gdy ujemna If Kwota < 0 Then Ujemna = True Kwota = -Kwota End If 'konwersja na stringi Zlotowki = CStr(Int(Kwota)) Grosze = CStr(Kwota - Int(Kwota)) 'sprawdzenie, czy nie za duża, max 99 mln If Len(Zlotowki) > 9 Then Slownie = "# Kwota za duża, max 999 mln!" Exit Function End If 'ewentualne zaokrąglenie do 2 msc po przecinku 'tu drobna poprawka stąd wersja 1.01 'było ...= CStr(Round(CDbl(Grosze) * 100, 2)) If Len(Grosze) > 2 Then Grosze = CStr(Round(CDbl(Grosze), 2) * 100) End If 'kod zasadniczy '============== Select Case Len(Zlotowki) Case 1 To 3 wynikZlote = Trojka(Zlotowki) & _ OpisRzeduWielkosci(CLng(Zlotowki), "zł", False) Case 4 To 6 TrojkaZl = Right(Zlotowki, 3) TrojkaTys = Left(Zlotowki, Len(Zlotowki) - 3) wynikZlote = Trojka(TrojkaTys) & _ OpisRzeduWielkosci(CLng(TrojkaTys), "tys", True) _ & " " & Trojka(TrojkaZl) & _ OpisRzeduWielkosci(CLng(TrojkaZl), "zł", True) Case 7 To 9 TrojkaZl = Right(Zlotowki, 3) TrojkaTys = Mid(Zlotowki, Len(Zlotowki) - 5, 3) TrojkaMln = Left(Zlotowki, Len(Zlotowki) - 6) wynikZlote = Trojka(TrojkaMln) & _ OpisRzeduWielkosci(CLng(TrojkaMln), "mln", True) _ & " " & Trojka(TrojkaTys) & _ OpisRzeduWielkosci(CLng(TrojkaTys), "tys", True) _ & " " & Trojka(TrojkaZl) & _ OpisRzeduWielkosci(CLng(TrojkaZl), "zł", True) End Select If UlamkoweGrosze Then wynikGrosze = Format(Grosze, "00") & "/100" Else wynikGrosze = Trojka(Grosze) & _ OpisRzeduWielkosci(CLng(Grosze), "gr", False) If wynikGrosze = "" Then wynikGrosze = "zero groszy" End If If wynikZlote = "" Then wynikZlote = "zero złotych" Slownie = IIf(Ujemna, "minus ", "") & _ Trim(wynikZlote & " " & wynikGrosze) Exit Function Obsluga: MsgBox Err & " - " & Err.Description, vbCritical, WERSJA End Function Private Function OpisRzeduWielkosci( _ Liczba As Long, RzadWielkosci As String, _ WiekszeTysiac As Boolean) As String Dim JestZero As Boolean Dim DwieOstatnie As Long Dim Ostatnia As Long If Liczba = 0 Then If WiekszeTysiac Then If RzadWielkosci = "zł" Then OpisRzeduWielkosci = "złotych" End If Else OpisRzeduWielkosci = "" End If Exit Function End If DwieOstatnie = CLng(Right(CStr(Liczba), 2)) Ostatnia = CLng(Right(CStr(Liczba), 1)) Select Case RzadWielkosci Case "gr" Select Case DwieOstatnie Case 0, 5 To 19 OpisRzeduWielkosci = " groszy" Case 1 OpisRzeduWielkosci = " grosz" Case 2 To 4 OpisRzeduWielkosci = " grosze" Case Is > 19 Select Case Ostatnia Case 0, 1, Is > 4 OpisRzeduWielkosci = " groszy" Case 2 To 4 OpisRzeduWielkosci = " grosze" End Select End Select Case "zł" Select Case DwieOstatnie Case 0, 5 To 19 OpisRzeduWielkosci = " złotych" Case 1 OpisRzeduWielkosci = " złoty" Case 2 To 4 OpisRzeduWielkosci = " złote" Case Is > 19 Select Case Ostatnia Case 0, 1, Is > 4 OpisRzeduWielkosci = " złotych" Case 2 To 4 OpisRzeduWielkosci = " złote" End Select End Select Case "tys" Select Case DwieOstatnie Case 0, 5 To 19 OpisRzeduWielkosci = " tysięcy" Case 1 OpisRzeduWielkosci = " tysiąc" Case 2 To 4 OpisRzeduWielkosci = " tysiące" Case Is > 19 Select Case Ostatnia Case 0, 1, Is > 4 OpisRzeduWielkosci = " tysięcy" Case 2 To 4 OpisRzeduWielkosci = " tysiące" End Select End Select Case "mln" Select Case DwieOstatnie Case 0, 5 To 19 OpisRzeduWielkosci = " milionów" Case 1 OpisRzeduWielkosci = " milion" Case 2 To 4 OpisRzeduWielkosci = " miliony" Case Is > 19 Select Case Ostatnia Case 0, 1, Is > 4 OpisRzeduWielkosci = " milionów" Case 2 To 4 OpisRzeduWielkosci = " miliony" End Select End Select End Select End Function Private Function Trojka(strLiczba As String) As String Dim lngLiczba As Long Dim lngOstatnia As Long Dim lngDwieOstatnie As Long Dim Opis(19) As String Dim DziesOpis(10) As String Dim SetOpis(9) As String If CLng(strLiczba) = 0 Then Trojka = "" Exit Function End If Opis(0) = "zero" Opis(1) = "jeden" Opis(2) = "dwa" Opis(3) = "trzy" Opis(4) = "cztery" Opis(5) = "pięć" Opis(6) = "sześć" Opis(7) = "siedem" Opis(8) = "osiem" Opis(9) = "dziewięć" Opis(10) = "dziesięć" Opis(11) = "jedenaście" Opis(12) = "dwanaście" Opis(13) = "trzynaście" Opis(14) = "czternaście" Opis(15) = "piętnaście" Opis(16) = "szesnaście" Opis(17) = "siedemnaście" Opis(18) = "osiemnaście" Opis(19) = "dziewiętnaście" DziesOpis(0) = "zero" DziesOpis(1) = "dziesięć" DziesOpis(2) = "dwadzieścia" DziesOpis(3) = "trzydzieści" DziesOpis(4) = "czterdzieści" DziesOpis(5) = "pięćdziesiąt" DziesOpis(6) = "sześćdziesiąt" DziesOpis(7) = "siedemdziesiąt" DziesOpis(8) = "osiemdziesiąt" DziesOpis(9) = "dziewięćdziesiąt" SetOpis(0) = "zero" SetOpis(1) = "sto" SetOpis(2) = "dwieście" SetOpis(3) = "trzysta" SetOpis(4) = "czterysta" SetOpis(5) = "pięćset" SetOpis(6) = "sześćset" SetOpis(7) = "siedemset" SetOpis(8) = "osiemset" SetOpis(9) = "dziewięćset" lngLiczba = CLng(strLiczba) 'tu policzymy ostatnią lngOstatnia = CLng(Right(strLiczba, 1)) Select Case lngLiczba Case Is < 20 Trojka = Opis(lngLiczba) Case Is < 100 If lngLiczba Mod 10 = 0 Then Trojka = DziesOpis(lngLiczba / 10) Else Trojka = DziesOpis((lngLiczba - lngOstatnia) / 10) _ & " " & Opis(lngOstatnia) End If Case Else 'trzycyfrowa If lngLiczba Mod 100 = 0 Then Trojka = SetOpis(lngLiczba / 100) Else 'tu policzymy dwie ostatnie lngDwieOstatnie = CLng(Right(strLiczba, 2)) If lngLiczba Mod 10 = 0 Then Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _ & " " & DziesOpis(lngDwieOstatnie / 10) Else If lngDwieOstatnie < 20 Then Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _ & " " & Opis(lngDwieOstatnie) Else Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _ & " " & DziesOpis((lngDwieOstatnie - lngOstatnia) / 10) _ & " " & Opis(lngOstatnia) End If End If End If End Select End Function

Akademia VBA – Oferta

Wyróżnione

Opublikowany 26 stycznia 2021 przez Dariusz Kolasa

Odpowiedz

Tworzę i naprawiam aplikacje VBA/SQL/Makra. Moje aplikacje wyróżnia:

Dopasowanie do potrzeb klienta
Otwarty i dobrze skomentowany kod źródłowy
Instrukcja obsługi aplikacji
Szkolenia umożliwiające rozwijanie aplikacji własnymi siłami.

Mam 25 lat doświadczenia w szkoleniach i tworzeniu aplikacji dla biznesu. Tworzę aplikacje głównie w oparciu o środowisko Excel i VBA ale także SQL Server, Access i Power BI.

Pozdrawiam i zapraszam do współpracy

Dariusz Kolasa

Deklaracja zmiennych

Opublikowany 6 lipca 2012 przez Dariusz Kolasa

Dla początkujących użytkowników VBA nieodmiennie zagadką jest deklarowanie zmiennych. Po pierwsze w ogóle nie wiadomo po co to pisać, skoro bez tego i tak działa, a po drugie nazwy typów zmiennych nie brzmią zbyt przyjaźnie.
Niestety brak stosowania i rozumienia deklaracji jest głównym powodem błędów, literówek, spowolnienia działania kodu i niewygody jego pisania. Temat nie jest bardzo prosty, ale bardzo ważny. Tu krótko wymienię zalety rozumienia i stosowania właściwych deklaracji:

Kod działa nawet do 4 razy szybciej
Łatwiej pisać kod bo zmienne zadeklarowane są wspomagane przez technologię podpowiadania słów kluczowych – Intellisense
Unikamy literówek
Piszemy kod wysokiej jakości pozwalający na szybsze wychwytywanie błędów – np niezgodność typu co przy przeoczeniu może prowadzić do negatywnych konsekwencji
Poprawiamy czytelność kodu

Problem polega na tym, że ta wiedza przychodzi z czasem, a tego jak zwykle wszystkim brakuje …

Odwieczny problem: Funkcja Slownie

Opublikowany 24 kwietnia 2011 przez Dariusz Kolasa

Jak na razie to największy kawałek kodu na tej stronie. Funkcja Slownie, czyli zamieniająca kwotę na jej słowny odpowiednik nie jest dostępna w Excelu ani w żadnej innej aplikacji Microsoft Office (o ile mi wiadomo).

I tu korekta (jak sądzę). W komentarzu pod tym artykułem znajduje się funkcja działająca w SQL Server Reporting Services. Komentarz autorstwa Pana Adama.

Oczywiście w Sieci można znaleźć wiele przykładów jej implementacji ale cóż warta byłaby strona o VBA, gdyby jej tu nie można było znaleźć. Wszelkie wytknięte błędy i konstruktywne uwagi krytyczne będą mile widziane (dwa błędy już zostały wykryte i poprawione). Funkcja korzysta z dwóch pomocniczych funkcji prywatnych, bez których nie będzie działać. Oto kod:

 
Option Explicit
 
Function Slownie(Kwota As Variant) As String
   '==================================
    ' UWAGA! Funkcja wymaga obu funkcji
    ' prywatnych zamieszczonych poniżej
    '==================================
 
    Const WERSJA As String = _
        "Funkcja Słownie v.1.02 (Akademia-VBA.pl)"
 
    Dim Opis(19) As String
    Dim DziesOpis(2 To 10) As String
    Dim SetOpis(1 To 9) As String
 
    Dim Zlotowki As String
    Dim Grosze As String
 
    Dim TrojkaZl As String
    Dim TrojkaTys As String
    Dim TrojkaMln As String
 
    Dim wynikGrosze As String
    Dim wynikZlote As String
    Dim Ujemna As Boolean
 
    On Error GoTo Obsluga
 
    'sprawdzenie czy puste
    If IsNull(Kwota) Or IsEmpty(Kwota) Then
        Slownie = "# Brak kwoty!"
        Exit Function
    End If
 
    'sprawdzenie czy liczba
    If Not IsNumeric(Kwota) Then
        Slownie = "# Nieprawidłowy typ wartości!"
        Exit Function
    End If
 
    'gdy ujemna
    If Kwota < 0 Then
        Ujemna = True
        Kwota = -Kwota
    End If
 
    'konwersja na stringi
    Zlotowki = CStr(Int(Kwota))
    Grosze = CStr(Kwota - Int(Kwota))
 
    'sprawdzenie, czy nie za duża, max 99 mln
    If Len(Zlotowki) > 9 Then
        Slownie = "# Kwota za duża, max 999 mln!"
        Exit Function
    End If
 
    'ewentualne zaokrąglenie do 2 msc po przecinku
    'tu drobna poprawka stąd wersja 1.01
    'było ...= CStr(Round(CDbl(Grosze) * 100, 2))
    If Len(Grosze) > 2 Then
        Grosze = CStr(Round(CDbl(Grosze), 2) * 100)
    End If
 
    'kod zasadniczy
    '==============
    Select Case Len(Zlotowki)
    Case 1 To 3
        wynikZlote = Trojka(Zlotowki) & _
            OpisRzeduWielkosci(CLng(Zlotowki), "zł", False)
    Case 4 To 6
        TrojkaZl = Right(Zlotowki, 3)
        TrojkaTys = Left(Zlotowki, Len(Zlotowki) - 3)
        wynikZlote = Trojka(TrojkaTys) & _
            OpisRzeduWielkosci(CLng(TrojkaTys), "tys", True) _
            & " " & Trojka(TrojkaZl) & _
            OpisRzeduWielkosci(CLng(TrojkaZl), "zł", True)
    Case 7 To 9
        TrojkaZl = Right(Zlotowki, 3)
        TrojkaTys = Mid(Zlotowki, Len(Zlotowki) - 5, 3)
        TrojkaMln = Left(Zlotowki, Len(Zlotowki) - 6)
        wynikZlote = Trojka(TrojkaMln) & _
            OpisRzeduWielkosci(CLng(TrojkaMln), "mln", True) _
            & " " & Trojka(TrojkaTys) & _
            OpisRzeduWielkosci(CLng(TrojkaTys), "tys", True) _
            & " " & Trojka(TrojkaZl) & _
            OpisRzeduWielkosci(CLng(TrojkaZl), "zł", True)
    End Select
 
    wynikGrosze = Trojka(Grosze) & _
        OpisRzeduWielkosci(CLng(Grosze), "gr", False)
 
    If wynikGrosze = "" Then wynikGrosze = "zero groszy"
 
    Slownie = IIf(Ujemna, "minus ", "") & _
        Trim(wynikZlote & " " & wynikGrosze)
 
    Exit Function
Obsluga:
    MsgBox Err & " - " & Err.Description, vbCritical, WERSJA
End Function
 
Private Function OpisRzeduWielkosci( _
        Liczba As Long, RzadWielkosci As String, _
        WiekszeTysiac As Boolean) As String
 
    Dim JestZero As Boolean
    Dim DwieOstatnie As Long
    Dim Ostatnia As Long
 
    If Liczba = 0 Then
        If WiekszeTysiac Then
            If RzadWielkosci = "zł" Then
                OpisRzeduWielkosci = "złotych"
            End If
        Else
            OpisRzeduWielkosci = ""
        End If
        Exit Function
    End If
 
    DwieOstatnie = CLng(Right(CStr(Liczba), 2))
    Ostatnia = CLng(Right(CStr(Liczba), 1))
 
    Select Case RzadWielkosci
    Case "gr"
        Select Case DwieOstatnie
        Case 0, 5 To 19
            OpisRzeduWielkosci = " groszy"
        Case 1
            OpisRzeduWielkosci = " grosz"
        Case 2 To 4
            OpisRzeduWielkosci = " grosze"
        Case Is > 19
            Select Case Ostatnia
            Case 0, 1, Is > 4
                OpisRzeduWielkosci = " groszy"
            Case 2 To 4
                OpisRzeduWielkosci = " grosze"
            End Select
        End Select
    Case "zł"
        Select Case DwieOstatnie
        Case 0, 5 To 19
            OpisRzeduWielkosci = " złotych"
        Case 1
            OpisRzeduWielkosci = " złoty"
        Case 2 To 4
            OpisRzeduWielkosci = " złote"
        Case Is > 19
            Select Case Ostatnia
            Case 0, 1, Is > 4
                OpisRzeduWielkosci = " złotych"
            Case 2 To 4
                OpisRzeduWielkosci = " złote"
            End Select
        End Select
    Case "tys"
        Select Case DwieOstatnie
        Case 0, 5 To 19
            OpisRzeduWielkosci = " tysięcy"
        Case 1
            OpisRzeduWielkosci = " tysiąc"
        Case 2 To 4
            OpisRzeduWielkosci = " tysiące"
        Case Is > 19
            Select Case Ostatnia
            Case 0, 1, Is > 4
                OpisRzeduWielkosci = " tysięcy"
            Case 2 To 4
                OpisRzeduWielkosci = " tysiące"
            End Select
        End Select
    Case "mln"
        Select Case DwieOstatnie
        Case 0, 5 To 19
            OpisRzeduWielkosci = " milionów"
        Case 1
            OpisRzeduWielkosci = " milion"
        Case 2 To 4
            OpisRzeduWielkosci = " miliony"
        Case Is > 19
            Select Case Ostatnia
            Case 0, 1, Is > 4
                OpisRzeduWielkosci = " milionów"
            Case 2 To 4
                OpisRzeduWielkosci = " miliony"
            End Select
        End Select
    End Select
End Function
 
Private Function Trojka(strLiczba As String) As String
    Dim lngLiczba As Long
    Dim lngOstatnia As Long
    Dim lngDwieOstatnie As Long
 
    Dim Opis(19) As String
    Dim DziesOpis(10) As String
    Dim SetOpis(9) As String
 
    If CLng(strLiczba) = 0 Then
        Trojka = ""
        Exit Function
    End If
 
    Opis(0) = "zero"
    Opis(1) = "jeden"
    Opis(2) = "dwa"
    Opis(3) = "trzy"
    Opis(4) = "cztery"
    Opis(5) = "pięć"
    Opis(6) = "sześć"
    Opis(7) = "siedem"
    Opis(8) = "osiem"
    Opis(9) = "dziewięć"
    Opis(10) = "dziesięć"
    Opis(11) = "jedenaście"
    Opis(12) = "dwanaście"
    Opis(13) = "trzynaście"
    Opis(14) = "czternaście"
    Opis(15) = "piętnaście"
    Opis(16) = "szesnaście"
    Opis(17) = "siedemnaście"
    Opis(18) = "osiemnaście"
    Opis(19) = "dziewiętnaście"
 
    DziesOpis(0) = "zero"
    DziesOpis(1) = "dziesięć"
    DziesOpis(2) = "dwadzieścia"
    DziesOpis(3) = "trzydzieści"
    DziesOpis(4) = "czterdzieści"
    DziesOpis(5) = "pięćdziesiąt"
    DziesOpis(6) = "sześćdziesiąt"
    DziesOpis(7) = "siedemdziesiąt"
    DziesOpis(8) = "osiemdziesiąt"
    DziesOpis(9) = "dziewięćdziesiąt"
 
    SetOpis(0) = "zero"
    SetOpis(1) = "sto"
    SetOpis(2) = "dwieście"
    SetOpis(3) = "trzysta"
    SetOpis(4) = "czterysta"
    SetOpis(5) = "pięćset"
    SetOpis(6) = "sześćset"
    SetOpis(7) = "siedemset"
    SetOpis(8) = "osiemset"
    SetOpis(9) = "dziewięćset"
 
    lngLiczba = CLng(strLiczba)
 
    'tu policzymy ostatnią
    lngOstatnia = CLng(Right(strLiczba, 1))
 
    Select Case lngLiczba
    Case Is < 20
        Trojka = Opis(lngLiczba)
    Case Is < 100
        If lngLiczba Mod 10 = 0 Then
            Trojka = DziesOpis(lngLiczba / 10)
        Else
            Trojka = DziesOpis((lngLiczba - lngOstatnia) / 10) _
                & " " & Opis(lngOstatnia)
        End If
    Case Else 'trzycyfrowa
        If lngLiczba Mod 100 = 0 Then
            Trojka = SetOpis(lngLiczba / 100)
        Else
            'tu policzymy dwie ostatnie
            lngDwieOstatnie = CLng(Right(strLiczba, 2))
 
            If lngLiczba Mod 10 = 0 Then
                Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _
                    & " " & DziesOpis(lngDwieOstatnie / 10)
            Else
                If lngDwieOstatnie < 20 Then
                    Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _
                        & " " & Opis(lngDwieOstatnie)
                Else
                    Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _
                        & " " & DziesOpis((lngDwieOstatnie - lngOstatnia) / 10) _
                        & " " & Opis(lngOstatnia)
                End If
            End If
        End If
    End Select
End Function

Option Explicit Function Slownie(Kwota As Variant) As String '================================== ' UWAGA! Funkcja wymaga obu funkcji ' prywatnych zamieszczonych poniżej '================================== Const WERSJA As String = _ "Funkcja Słownie v.1.02 (Akademia-VBA.pl)" Dim Opis(19) As String Dim DziesOpis(2 To 10) As String Dim SetOpis(1 To 9) As String Dim Zlotowki As String Dim Grosze As String Dim TrojkaZl As String Dim TrojkaTys As String Dim TrojkaMln As String Dim wynikGrosze As String Dim wynikZlote As String Dim Ujemna As Boolean On Error GoTo Obsluga 'sprawdzenie czy puste If IsNull(Kwota) Or IsEmpty(Kwota) Then Slownie = "# Brak kwoty!" Exit Function End If 'sprawdzenie czy liczba If Not IsNumeric(Kwota) Then Slownie = "# Nieprawidłowy typ wartości!" Exit Function End If 'gdy ujemna If Kwota < 0 Then Ujemna = True Kwota = -Kwota End If 'konwersja na stringi Zlotowki = CStr(Int(Kwota)) Grosze = CStr(Kwota - Int(Kwota)) 'sprawdzenie, czy nie za duża, max 99 mln If Len(Zlotowki) > 9 Then Slownie = "# Kwota za duża, max 999 mln!" Exit Function End If 'ewentualne zaokrąglenie do 2 msc po przecinku 'tu drobna poprawka stąd wersja 1.01 'było ...= CStr(Round(CDbl(Grosze) * 100, 2)) If Len(Grosze) > 2 Then Grosze = CStr(Round(CDbl(Grosze), 2) * 100) End If 'kod zasadniczy '============== Select Case Len(Zlotowki) Case 1 To 3 wynikZlote = Trojka(Zlotowki) & _ OpisRzeduWielkosci(CLng(Zlotowki), "zł", False) Case 4 To 6 TrojkaZl = Right(Zlotowki, 3) TrojkaTys = Left(Zlotowki, Len(Zlotowki) - 3) wynikZlote = Trojka(TrojkaTys) & _ OpisRzeduWielkosci(CLng(TrojkaTys), "tys", True) _ & " " & Trojka(TrojkaZl) & _ OpisRzeduWielkosci(CLng(TrojkaZl), "zł", True) Case 7 To 9 TrojkaZl = Right(Zlotowki, 3) TrojkaTys = Mid(Zlotowki, Len(Zlotowki) - 5, 3) TrojkaMln = Left(Zlotowki, Len(Zlotowki) - 6) wynikZlote = Trojka(TrojkaMln) & _ OpisRzeduWielkosci(CLng(TrojkaMln), "mln", True) _ & " " & Trojka(TrojkaTys) & _ OpisRzeduWielkosci(CLng(TrojkaTys), "tys", True) _ & " " & Trojka(TrojkaZl) & _ OpisRzeduWielkosci(CLng(TrojkaZl), "zł", True) End Select wynikGrosze = Trojka(Grosze) & _ OpisRzeduWielkosci(CLng(Grosze), "gr", False) If wynikGrosze = "" Then wynikGrosze = "zero groszy" Slownie = IIf(Ujemna, "minus ", "") & _ Trim(wynikZlote & " " & wynikGrosze) Exit Function Obsluga: MsgBox Err & " - " & Err.Description, vbCritical, WERSJA End Function Private Function OpisRzeduWielkosci( _ Liczba As Long, RzadWielkosci As String, _ WiekszeTysiac As Boolean) As String Dim JestZero As Boolean Dim DwieOstatnie As Long Dim Ostatnia As Long If Liczba = 0 Then If WiekszeTysiac Then If RzadWielkosci = "zł" Then OpisRzeduWielkosci = "złotych" End If Else OpisRzeduWielkosci = "" End If Exit Function End If DwieOstatnie = CLng(Right(CStr(Liczba), 2)) Ostatnia = CLng(Right(CStr(Liczba), 1)) Select Case RzadWielkosci Case "gr" Select Case DwieOstatnie Case 0, 5 To 19 OpisRzeduWielkosci = " groszy" Case 1 OpisRzeduWielkosci = " grosz" Case 2 To 4 OpisRzeduWielkosci = " grosze" Case Is > 19 Select Case Ostatnia Case 0, 1, Is > 4 OpisRzeduWielkosci = " groszy" Case 2 To 4 OpisRzeduWielkosci = " grosze" End Select End Select Case "zł" Select Case DwieOstatnie Case 0, 5 To 19 OpisRzeduWielkosci = " złotych" Case 1 OpisRzeduWielkosci = " złoty" Case 2 To 4 OpisRzeduWielkosci = " złote" Case Is > 19 Select Case Ostatnia Case 0, 1, Is > 4 OpisRzeduWielkosci = " złotych" Case 2 To 4 OpisRzeduWielkosci = " złote" End Select End Select Case "tys" Select Case DwieOstatnie Case 0, 5 To 19 OpisRzeduWielkosci = " tysięcy" Case 1 OpisRzeduWielkosci = " tysiąc" Case 2 To 4 OpisRzeduWielkosci = " tysiące" Case Is > 19 Select Case Ostatnia Case 0, 1, Is > 4 OpisRzeduWielkosci = " tysięcy" Case 2 To 4 OpisRzeduWielkosci = " tysiące" End Select End Select Case "mln" Select Case DwieOstatnie Case 0, 5 To 19 OpisRzeduWielkosci = " milionów" Case 1 OpisRzeduWielkosci = " milion" Case 2 To 4 OpisRzeduWielkosci = " miliony" Case Is > 19 Select Case Ostatnia Case 0, 1, Is > 4 OpisRzeduWielkosci = " milionów" Case 2 To 4 OpisRzeduWielkosci = " miliony" End Select End Select End Select End Function Private Function Trojka(strLiczba As String) As String Dim lngLiczba As Long Dim lngOstatnia As Long Dim lngDwieOstatnie As Long Dim Opis(19) As String Dim DziesOpis(10) As String Dim SetOpis(9) As String If CLng(strLiczba) = 0 Then Trojka = "" Exit Function End If Opis(0) = "zero" Opis(1) = "jeden" Opis(2) = "dwa" Opis(3) = "trzy" Opis(4) = "cztery" Opis(5) = "pięć" Opis(6) = "sześć" Opis(7) = "siedem" Opis(8) = "osiem" Opis(9) = "dziewięć" Opis(10) = "dziesięć" Opis(11) = "jedenaście" Opis(12) = "dwanaście" Opis(13) = "trzynaście" Opis(14) = "czternaście" Opis(15) = "piętnaście" Opis(16) = "szesnaście" Opis(17) = "siedemnaście" Opis(18) = "osiemnaście" Opis(19) = "dziewiętnaście" DziesOpis(0) = "zero" DziesOpis(1) = "dziesięć" DziesOpis(2) = "dwadzieścia" DziesOpis(3) = "trzydzieści" DziesOpis(4) = "czterdzieści" DziesOpis(5) = "pięćdziesiąt" DziesOpis(6) = "sześćdziesiąt" DziesOpis(7) = "siedemdziesiąt" DziesOpis(8) = "osiemdziesiąt" DziesOpis(9) = "dziewięćdziesiąt" SetOpis(0) = "zero" SetOpis(1) = "sto" SetOpis(2) = "dwieście" SetOpis(3) = "trzysta" SetOpis(4) = "czterysta" SetOpis(5) = "pięćset" SetOpis(6) = "sześćset" SetOpis(7) = "siedemset" SetOpis(8) = "osiemset" SetOpis(9) = "dziewięćset" lngLiczba = CLng(strLiczba) 'tu policzymy ostatnią lngOstatnia = CLng(Right(strLiczba, 1)) Select Case lngLiczba Case Is < 20 Trojka = Opis(lngLiczba) Case Is < 100 If lngLiczba Mod 10 = 0 Then Trojka = DziesOpis(lngLiczba / 10) Else Trojka = DziesOpis((lngLiczba - lngOstatnia) / 10) _ & " " & Opis(lngOstatnia) End If Case Else 'trzycyfrowa If lngLiczba Mod 100 = 0 Then Trojka = SetOpis(lngLiczba / 100) Else 'tu policzymy dwie ostatnie lngDwieOstatnie = CLng(Right(strLiczba, 2)) If lngLiczba Mod 10 = 0 Then Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _ & " " & DziesOpis(lngDwieOstatnie / 10) Else If lngDwieOstatnie < 20 Then Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _ & " " & Opis(lngDwieOstatnie) Else Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _ & " " & DziesOpis((lngDwieOstatnie - lngOstatnia) / 10) _ & " " & Opis(lngOstatnia) End If End If End If End Select End Function

Scalacz – aplikacja do automatycznej konsolidacji danych z wielu skoroszytów

Opublikowany 23 lipca 2010 przez Dariusz Kolasa

Tym razem nieco większa porcja kodu. Jest to w miarę kompletna aplikacja, gotowa do użycia. Wystarczy skopiować poniższy kod do modułu publicznego w Excelu (Alt+F11, Insert – Module). Aplikacja konsoliduje dane z wielu skoroszytów i zapisuje je w zbiorczym, nowo tworzonym arkuszu. Przed użyciem proszę uważnie przeczytać założenia

Public Const WERSJA As String = "Scalacz v.1.0 (Akademia-VBA.pl)"
 
' ==================================================
' ZAŁOŻENIA:
' 1. Wszystkie skoroszyty do scalenia znajdują się w jednym folderze
' 2. Nie ma tam żadnych skoroszytów przypadkowych (w tym docelowego)
' 3. Dane do scalenia są zawsze w pierwszym arkuszu i mają jednakowe kolumny
' 4. Dane do scalenia mają nagłówki
' ==================================================
 
Sub Scalaj()
    Dim Skonsolidowany As Worksheet
    Dim Plik As String
    Dim Skor As Workbook, Ark As Worksheet
    Dim Pocz As Range, Kon As Range
    Dim Naglowki As Range, Podzakres As Range, KomDocel As Range
    Dim Licznik As Long, LW As Long, LK As Long
    Dim ZakresDocel As Range, LW_Docel As Long
    Dim Folder As String
 
    Folder = WskazFolder("Wskaż folder z plikami do scalenia", "Scalaj")
    If Len(Folder) = 0 Then
        MsgBox "Nie wskazano foldera źródłowego", vbExclamation, WERSJA
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Set Skonsolidowany = Worksheets.Add()
    Plik = Dir(Folder & "*.xls")
    Do Until Len(Plik) = 0
        Licznik = Licznik + 1
        Application.StatusBar = "Konsolidacja pliku nr " & Licznik
        Set Skor = Workbooks.Open(Folder & Plik)
        Set Ark = Skor.Sheets(1)
        If Licznik = 1 Then
            Set Naglowki = Ark.Range("A1").CurrentRegion.Rows(1)
            Naglowki.Copy Skonsolidowany.Range("A1")
            Set KomDocel = Skonsolidowany.Range("A2")
        Else
            Set ZakresDocel = Skonsolidowany.Range("A1").CurrentRegion
            LW_Docel = ZakresDocel.Rows.Count
            Set KomDocel = Skonsolidowany.Cells(LW_Docel + 1, 1)
        End If
        Set Podzakres = Ark.Range("A1").CurrentRegion
        LW = Podzakres.Rows.Count
        LK = Podzakres.Columns.Count
        Set Podzakres = Range(Ark.Range("A2"), Ark.Cells(LW, LK))
        Podzakres.Copy KomDocel
        Skor.Close False
        Plik = Dir
    Loop
    Skonsolidowany.Name = "Skonsolidowany" & StempelCzasowy
    Skonsolidowany.UsedRange.EntireColumn.AutoFit
    Skonsolidowany.Range("A1").Select
    'Application.StatusBar = "Gotowy"
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox "Konsolidacja " & Licznik & " arkuszy zakończona", vbInformation, WERSJA
End Sub
 
Function StempelCzasowy() As String
    StempelCzasowy = Format(Now(), "_yyyymmdd_hhmmss")
End Function
 
Function WskazFolder(TytulOkna As String, TytulPrzycisku As String) As String
    Dim Okno As FileDialog
    Dim Wybrane As String
    Set Okno = Application.FileDialog(msoFileDialogFolderPicker)
    Okno.Title = TytulOkna
    Okno.ButtonName = TytulPrzycisku
    If Okno.Show = -1 Then
        Wybrane = Okno.SelectedItems(1)
        If Right(Wybrane, 1) <> "\" Then
            WskazFolder = Wybrane & "\"
        Else
            WskazFolder = Wybrane
        End If
    End If
End Function

Public Const WERSJA As String = "Scalacz v.1.0 (Akademia-VBA.pl)" ' ================================================== ' ZAŁOŻENIA: ' 1. Wszystkie skoroszyty do scalenia znajdują się w jednym folderze ' 2. Nie ma tam żadnych skoroszytów przypadkowych (w tym docelowego) ' 3. Dane do scalenia są zawsze w pierwszym arkuszu i mają jednakowe kolumny ' 4. Dane do scalenia mają nagłówki ' ================================================== Sub Scalaj() Dim Skonsolidowany As Worksheet Dim Plik As String Dim Skor As Workbook, Ark As Worksheet Dim Pocz As Range, Kon As Range Dim Naglowki As Range, Podzakres As Range, KomDocel As Range Dim Licznik As Long, LW As Long, LK As Long Dim ZakresDocel As Range, LW_Docel As Long Dim Folder As String Folder = WskazFolder("Wskaż folder z plikami do scalenia", "Scalaj") If Len(Folder) = 0 Then MsgBox "Nie wskazano foldera źródłowego", vbExclamation, WERSJA Exit Sub End If Application.ScreenUpdating = False Set Skonsolidowany = Worksheets.Add() Plik = Dir(Folder & "*.xls") Do Until Len(Plik) = 0 Licznik = Licznik + 1 Application.StatusBar = "Konsolidacja pliku nr " & Licznik Set Skor = Workbooks.Open(Folder & Plik) Set Ark = Skor.Sheets(1) If Licznik = 1 Then Set Naglowki = Ark.Range("A1").CurrentRegion.Rows(1) Naglowki.Copy Skonsolidowany.Range("A1") Set KomDocel = Skonsolidowany.Range("A2") Else Set ZakresDocel = Skonsolidowany.Range("A1").CurrentRegion LW_Docel = ZakresDocel.Rows.Count Set KomDocel = Skonsolidowany.Cells(LW_Docel + 1, 1) End If Set Podzakres = Ark.Range("A1").CurrentRegion LW = Podzakres.Rows.Count LK = Podzakres.Columns.Count Set Podzakres = Range(Ark.Range("A2"), Ark.Cells(LW, LK)) Podzakres.Copy KomDocel Skor.Close False Plik = Dir Loop Skonsolidowany.Name = "Skonsolidowany" & StempelCzasowy Skonsolidowany.UsedRange.EntireColumn.AutoFit Skonsolidowany.Range("A1").Select 'Application.StatusBar = "Gotowy" Application.StatusBar = False Application.ScreenUpdating = True MsgBox "Konsolidacja " & Licznik & " arkuszy zakończona", vbInformation, WERSJA End Sub Function StempelCzasowy() As String StempelCzasowy = Format(Now(), "_yyyymmdd_hhmmss") End Function Function WskazFolder(TytulOkna As String, TytulPrzycisku As String) As String Dim Okno As FileDialog Dim Wybrane As String Set Okno = Application.FileDialog(msoFileDialogFolderPicker) Okno.Title = TytulOkna Okno.ButtonName = TytulPrzycisku If Okno.Show = -1 Then Wybrane = Okno.SelectedItems(1) If Right(Wybrane, 1) <> "\" Then WskazFolder = Wybrane & "\" Else WskazFolder = Wybrane End If End If End Function

Jak skorzystać z kodu VBA znalezionego w Internecie

Opublikowany 4 lipca 2010 przez Dariusz Kolasa

Odpowiedz

Dla początkujących może być to poważny problem. Przede wszystkim trzeba ocenić czy przypadkiem kod nie jest szkodliwy. Na szczęście w przypadku kodu VBA jest to bardzo rzadko spotykane. Po drugie trzeba rozróżnić czy jest to kod do umieszczenia w module publicznym, czy prywatnym module formularza, raportu, skoroszytu czy arkusza.

Moduł publiczny wstawiamy z menu Instert – Module (wcześniej Alt-F11 aby otworzyć edytor VBA). Tu wklejamy funkcje, które mają być dostępne z poziomu funkcji użytkownika w Excelu czy też w każdej kwerendzie, raporcie czy formularzu w Accessie (np wrzucamy tu funkcję Slownie, jeżeli chcemy aby była powszechnie dostępna w całej bazie)

Moduł prywatny zawsze związany jest z jakimś obiektem. Tylko tu możemy umieścić kod automatycznie wykonujący się z powodu zdarzeń generowanych przez użytkownika takich jak otwarcie czy zamknięcie dokumentu, lub kliknięcie w przycisk. Jeżeli widzimy kod bezpośrednio odwołujący się do kontrolek na formularzu, jak np poniższe dwie procedury:

Private Sub UserForm_Initialize()
 
    przyciskUruchom.Enabled = False
    listaFunkcji.AddItem "Funkcja1"
    listaFunkcji.AddItem "Funkcja2"
 
End Sub
 
Private Sub listaFunkcji_Click()
    przyciskUruchom.Enabled = True
End Sub

to znaczy, że aby przetestować taki kod trzeba: po pierwsze trzeba utworzyć formularz, po drugie umieścić na nim pole listy i przycisk a po trzecie odpowiednio je ponazywać (właściwość Name kontrolki). Efektem powyższych procedur jest początkowe wyłączenie przycisku i załadowanie pola listy. Następnie gdy użytkownik kliknie coś na liście, przycisk zostanie włączony.

Tworzenie i użycie własnej zmiennej obiektowej typu Excel.Range

Opublikowany 27 czerwca 2010 przez Dariusz Kolasa

Odpowiedz

Przykład na tworzenie własnej zmiennej typu Range i posługiwanie się właściwościami obiektu Range, typu Range:

CurrentRegion
Rows(W)
Columns(K)
Cells(W,K)

Sub WlasnaZmiennaRange()
 
    Dim Zakres As Range
    Dim LW As Long, LK As Long
 
    'sprawdzenie, czy aktywna komórka znajduje się
    'w zakresie danych, przy pomocy własnej funkcji logicznej
    If fnBrakZakresu Then Exit Sub
 
    'ustawienie referencji do obiektu
    'na podstawie właściwości "Bieżący obszar" aktywnej komórki
    Set Zakres = ActiveCell.CurrentRegion
 
    'kolorowanie zakresu poprzez własną zmienną
    Zakres.Interior.ColorIndex = 35
 
    'odczyt liczby wierszy i kolumn zakresu
    LW = Zakres.Rows.Count
    LK = Zakres.Columns.Count
 
    'wyświetlenie wartości zmiennych w oknie debuggera
    Debug.Print "lw: " & LW
    Debug.Print "lk: " & LK
 
    'kolorowanie skrajnych wierszy
    Zakres.Rows(1).Interior.ColorIndex = 34
    Zakres.Rows(LW).Interior.ColorIndex = 34
 
    'i kolumn
    Zakres.Columns(1).Interior.ColorIndex = 34
    Zakres.Columns(LK).Interior.ColorIndex = 34
 
    'kolorowanie narożników zakresu
    Zakres.Cells(1, 1).Interior.ColorIndex = 36
    Zakres.Cells(1, LK).Interior.ColorIndex = 36
    Zakres.Cells(LW, 1).Interior.ColorIndex = 36
    Zakres.Cells(LW, LK).Interior.ColorIndex = 36
 
End Sub

Na koniec funkcja logiczna, z której korzysta powyższa procedura:

Function fnBrakZakresu() As Boolean
    If Len(ActiveCell) = 0 Then
        MsgBox "Ustaw się w niepustej komórce zakresu danych!"
        fnBrakZakresu = True
    End If
End Function

Jak bezpiecznie wyłączyć komunikaty ostrzegawcze w Excelu

Opublikowany 15 czerwca 2010 przez Dariusz Kolasa

Odpowiedz

Z wyłączeniem komunikatów ostrzegawczych nie ma problemu. Jest to właściwość logiczna Excela. Problemem jest fakt, że pozostawienie wyłączonych komunikatów ostrzegawczych jest bardzo niebezpieczne przy późniejszej normalnej pracy użytkownika. Poniżej przykład procedury, gdzie na pewno zawsze nastąpi przywrócenie komunikatów, nawet gdy wystąpi błąd w procedurze. Jest to możliwe przy użyciu poprawnej obsługi błędów.

Private Sub UsunBiezacyArkuszBezOstrzezenia()
 
    On Error GoTo Obsluga
 
    'wyłącz komunikaty ostrzegawcze
    Application.DisplayAlerts = False 
 
    ActiveSheet.Delete
 
Czyszczenie:
    On Error Resume Next
    Application.DisplayAlerts = True 'przywróć komunikaty
    Exit Sub
 
Obsluga:
    MsgBox Err & ". " & Err.Description
    Resume Czyszczenie
 
End Sub

Jak z VBA wywołać okno dialogowe Office do pobrania nazwy foldera od użytkownika

Opublikowany 14 czerwca 2010 przez Dariusz Kolasa

Odpowiedz

Nie możemy wymagać od użytkownika, aby poprawnie wpisywał nazwy foldera z ręki. Dużo wygodniej będzie mu użyć dobrze znanego mu okna dialogowego do wskazywania folderów. Dodatkowym bonusem jest, że można też wskazać folder właśnie utworzony w tym samym oknie. Bardzo wygodna funkcja…

'wymaga referencji do Microsoft Office XX Object Library
Function WskazFolder(TytulOkna As String, TytulPrzycisku As String) As String
    Dim Okno As FileDialog
    Dim Wybrane As String
    Set Okno = Application.FileDialog(msoFileDialogFolderPicker)
    Okno.Title = TytulOkna
    Okno.ButtonName = TytulPrzycisku
    If Okno.Show = -1 Then
        Wybrane = Okno.SelectedItems(1)
        If Right(Wybrane, 1) <> "\" Then
            WskazFolder = Wybrane & "\"
        Else
            WskazFolder = Wybrane
        End If
    End If
End Function

Akademia VBA

Czyli jak uzyskać władzę nad światem… danych

Archiwa tagu: Programowanie Excel

Słownie z groszami w postaci ułamka

Akademia VBA – Oferta

Wyróżnione

Deklaracja zmiennych

Odwieczny problem: Funkcja Slownie

Scalacz – aplikacja do automatycznej konsolidacji danych z wielu skoroszytów

Jak skorzystać z kodu VBA znalezionego w Internecie

Tworzenie i użycie własnej zmiennej obiektowej typu Excel.Range

Jak bezpiecznie wyłączyć komunikaty ostrzegawcze w Excelu

Jak z VBA wywołać okno dialogowe Office do pobrania nazwy foldera od użytkownika