Słownie z groszami w postaci ułamka

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

Akademia VBA – Oferta

Wyróżnione

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

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

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

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

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

Jak skorzystać z kodu VBA znalezionego w Internecie

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

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

  1. CurrentRegion
  2. Rows(W)
  3. Columns(K)
  4. 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

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

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