Funkcja do sprawdzania sprawdzania poprawności

Czasem możemy chcieć sprawdzić czy w danej komórce ustawiono sprawdzanie poprawności (walidację), np. aby jej nie popsuć wklejaniem
Poniżej funkcja logiczna, która to sprawdza

Function JestSprawdzaniePoprawnosci(KomSprawdzania As Range) As Boolean
    Dim Typ As Long
 
    On Error GoTo Obsluga
 
    Typ = KomSprawdzania.Validation.Type
    JestSprawdzaniePoprawnosci = True
    Exit Function
 
Obsluga:
    JestSprawdzaniePoprawnosci = False
 
End Function

Usuwanie niedozwolonych znaków w nazwie pliku

Jest to oczywiście nawiązanie do napisanej wcześniej funkcji sprawdzającej czy takie znaki występują (dostępna tutaj). Tym razem wersja konwertująca niedozwolony znak na podkreślenie, bez żadnych komunikatów, wygodna do użycia w pętli itp.

Function SkonwertowanaNazwaPliku(SprawdzanaNazwa As String) As String
    Dim tbl As Variant
    Dim NrZn As Long
    Dim Dlugosc As Long
    Dim Znak As String * 1
    Dim tblZnak As Variant
    Dim NiedozwolonyZnak As Boolean
 
    tbl = Array("#", "%", "&", "*", ":", "<", ">", "?", "/", "\", "{", "|", "}")
    Dlugosc = Len(SprawdzanaNazwa)
    For NrZn = 1 To Dlugosc
        Znak = Mid(SprawdzanaNazwa, NrZn, 1)
        NiedozwolonyZnak = False
        For Each tblZnak In tbl
            If tblZnak = Znak Then
                NiedozwolonyZnak = True
                Exit For
            End If
        Next
        If NiedozwolonyZnak Then
            SkonwertowanaNazwaPliku = SkonwertowanaNazwaPliku & "_"
        Else
            SkonwertowanaNazwaPliku = SkonwertowanaNazwaPliku & Znak
        End If
    Next
End Function

Warunkowe usuwanie wierszy

Spory kawałek kodu jak na tak prosty w sumie problem a to dlatego, że aplikacja sprawdza sobie najpierw czy ma z czym pracować i na dodatek robi kopię skasowanych wierszy

Option Explicit
 
Public Const WERSJA = "Warunkowe usuwanie wierszy v.1.0 (Akademia-VBA.pl)"
Public Const KOL_SPRAWDZANA As Long = 3
'
' Usuwa wiersz zakresu z nagłówkami gdy w kolumnie 3 jest pusto
' Usunięte wiersze zapisuje na wszelki w dodatkowym arkuszu
' Wcześniej aplikacja sprawdza, czy są dane
' i czy użytkownik ustawił w nich komórkę aktywną
'
 
Sub WarunkoweUsuwanieWierszy()
    Dim Zakres As Range
    Dim LW As Long, W As Long
    Dim Wiersz As Range
    Dim x As Long
    Dim ArkUsuwanychWierszy As Worksheet
    Dim Naglowki As Range
 
    If NienormalnyArkusz Then Exit Sub
    If NienormalneOkno Then Exit Sub
    If BrakZakresu Then Exit Sub
 
    Set Zakres = ActiveCell.CurrentRegion
    Set Naglowki = Zakres.Rows(1)
    Set ArkUsuwanychWierszy = Sheets.Add()
    ArkUsuwanychWierszy.Name = "Skasowane" & StempelCzasowy
    Naglowki.Copy ArkUsuwanychWierszy.Range("A1")
 
    LW = Zakres.Rows.Count
 
    For W = LW To 2 Step -1
        Application.StatusBar = "Analiza wiersza " & W
 
        If Len(Zakres.Cells(W, KOL_SPRAWDZANA)) = 0 Then 'czyli gdy pusto
            x = x + 1
            Set Wiersz = Zakres.Rows(W)
            Wiersz.Copy ArkUsuwanychWierszy.Cells(x + 1, 1)
            Wiersz.Delete
        End If
    Next
    ArkUsuwanychWierszy.UsedRange.EntireColumn.AutoFit
    Application.StatusBar = False
    MsgBox "Poczatkowa liczba wierszy: " & LW & vbNewLine & _
            "Liczba wierszy usuniętych: " & x & vbNewLine & _
            "Pozostało wierszy: " & LW - x, vbInformation, WERSJA
End Sub
 
Private Function NienormalnyArkusz() As Boolean
    If ActiveSheet.Type <> xlWorksheet Then
        MsgBox "Ustaw się w arkuszu danych!", vbExclamation, WERSJA
        NienormalnyArkusz = True
    End If
End Function
 
Private Function NienormalneOkno() As Boolean
    If ActiveWindow.Type <> xlWorkbook Then
        MsgBox "Ustaw się w oknie danych!", vbExclamation, WERSJA
        NienormalneOkno = True
    End If
End Function
 
Private Function BrakZakresu() As Boolean
    If Len(ActiveCell) = 0 Then
        MsgBox "Ustaw się w niepustej komórce zakresu danych!", vbExclamation, WERSJA
        BrakZakresu = True
    End If
End Function
 
Function StempelCzasowy() As String
    StempelCzasowy = Format(Now(), "_yyyymmdd_hhmmss")
End Function

Odświeżanie nazwanych zakresów

Często pojawiającym się problemem jest zmiana zakresów nazwanych zakresów 🙂
Poniższy kod dopasuje nowe zakresy do ich nazw. Opieramy się na założeniu, że zakresy nie sąsiadują bezpośrednio z innymi danymi

Sub AktualizujNazwy()
    Dim Nazwa As Name
    For Each Nazwa In Names
        Nazwa.RefersToRange.CurrentRegion.Name = Nazwa.Name
    Next
End Sub

Transpozycja części kolumn zakresu

Dzisiaj spory kawałek kodu. Aplikacja „Transpozycja części kolumn” naprawia błąd projektu tabelki, w której występuje grupa kolumn (np kolejne miesiące są nagłówkami kolumn). Zamienia ona te kolumny na dwie: Nagłówek i Wartość, odpowiednio wydłużając tabelkę przyległymi danymi. Taka tabelka dużo lepiej nadaje się do analizy…
Udanej transpozycji życzę 🙂

Option Explicit
 
Sub TranspozycjaCzesciKolumn()
 
    ' funkcjonalność:
    ' ===============
    ' Aplikacja zamienia zaznaczony zakres
    ' grupy kolumn w dwie kolumny - nagłówek i wartość,
    ' powtarzając dane przyległe
    ' dla każdego dokładanego wiersza.
    ' Wynik umieści w nowym arkuszu.
 
    ' założenia:
    ' ==========
    ' - zakres do transpozycji to końcowe kolumny tabeli
    '   wraz z nagłówkami (ma nagłówki!)
    ' - nazwy nagłówków kolumn docelowych
    '   to stałe NAGLOWEK i WARTOSC
    '   (można sobie zmienić ich wartość)
    ' - nie sprawdzamy, czy wynik zmieści się w arkuszu
 
    Const WERSJA As String = "Transpozycja części kolumn v.1.0 (Akademia-VBA.pl)"
    Const NAGLOWEK As String = "NAGŁÓWEK"
    Const WARTOSC As String = "WARTOŚĆ"
 
    Dim NazwaKolumny As String
    Dim ZakresTranspozycji As Range
    Dim ZakresPowtarzany As Range
    Dim ZakresCalkowity As Range
    Dim LW As Long, LK As Long, RoznicaK As Long, K As Long
    Dim LW_Wart As Long, W As Long
    Dim Ark As Worksheet
    Dim ZakresPowtarzany_BN As Range
    Dim KomNaglowkowa As Range, ZakresWartosci As Range
    Dim PoczNaglowki As Range, PoczWartosci As Range
 
    On Error GoTo Obsluga
 
    Set ZakresTranspozycji = Application.InputBox( _
        Prompt:="Podaj zakres kolumn do transpozycji (z nagłówkami)", _
        Title:=WERSJA, _
        Type:=8)
    LW = ZakresTranspozycji.Rows.Count
    LK = ZakresTranspozycji.Columns.Count
    Set ZakresCalkowity = ZakresTranspozycji.CurrentRegion
    RoznicaK = ZakresCalkowity.Columns.Count - LK
    Set ZakresPowtarzany = _
        ZakresCalkowity.Resize(LW, RoznicaK)
    ZakresPowtarzany.Interior.ColorIndex = 34
    ZakresTranspozycji.Interior.ColorIndex = 36
    Set Ark = Sheets.Add()
    Ark.Name = "Transpozycja" & StempelCzasowy
    ZakresPowtarzany.Copy Ark.Range("A1")
    Set ZakresPowtarzany_BN = _
        ZakresBezNaglowka(Ark.Range("A1").CurrentRegion)
    ZakresPowtarzany_BN.Interior.ColorIndex = 37
    LW_Wart = ZakresPowtarzany_BN.Rows.Count
    Set PoczNaglowki = Ark.Cells(1, RoznicaK + 1)
    PoczNaglowki = NAGLOWEK
    Set PoczWartosci = Ark.Cells(1, RoznicaK + 2)
    PoczWartosci = WARTOSC
    For K = 1 To LK
        Set KomNaglowkowa = ZakresTranspozycji.Cells(1, K)
        Set ZakresWartosci = _
            ZakresBezNaglowka(ZakresTranspozycji.Columns(K))
        For W = 1 To LW_Wart
            KomNaglowkowa.Copy PoczNaglowki.Offset(W, 0)
        Next
        Set PoczNaglowki = PoczNaglowki.Offset(LW_Wart, 0)
        ZakresWartosci.Copy PoczWartosci.Offset(1, 0)
        Set PoczWartosci = PoczWartosci.Offset(LW_Wart, 0)
        If K = LK Then Exit For
        ZakresPowtarzany_BN.Copy _
            ZakresPowtarzany_BN.Offset(LW_Wart * K, 0)
    Next
 
    Exit Sub
Obsluga:
    If Err = 424 Then
        MsgBox "Należy zaznaczyć zakres kolumn do transpozycji", _
            vbExclamation, WERSJA
    Else
        MsgBox Err & ". " & Err.Description, vbCritical, WERSJA
    End If
End Sub
 
Function ZakresBezNaglowka(Zakres As Range) As Excel.Range
 
    Dim LW As Long, LK As Long
 
    LW = Zakres.Rows.Count
    LK = Zakres.Columns.Count
    Set ZakresBezNaglowka = _
        Range(Zakres.Cells(2, 1), Zakres.Cells(LW, LK))
 
End Function
 
Function StempelCzasowy() As String
    StempelCzasowy = Format(Now(), "_yyyymmdd_hhmmss")
End Function

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

Pod Excelem można to zrobić na dwa sposoby:
Korzystając z biblioteki Office (funkcja bardzo podobna do WskazFolder):

Function WskazPlik(TytulOkna As String, TytulPrzycisku As String) As String
    Dim Okno As FileDialog
    Dim Wybrane As String
    Set Okno = Application.FileDialog(msoFileDialogFilePicker)
    Okno.Title = TytulOkna
    Okno.ButtonName = TytulPrzycisku
    If Okno.Show = -1 Then
        WskazPlik = Okno.SelectedItems(1)
    End If
End Function

Lub korzystając z metody Excela:

Function WskazPlik_MetodaExcel() As String
    WskazPlik_MetodaExcel = Excel.Application.GetOpenFilename()
End Function

Pierwsza funkcja jest nieco bardziej skomplikowana ale bardziej uniwersalna, druga jest skrajnie prosta i nie wymaga niczego poza Excelem. Oczywiście obie można rozbudować o możliwość filtrowania plików…

W komentarzach znajduje się dyskusja na temat konstrukcji wiążącej With..End With

Jak zacząć programowanie w VBA w Excelu 2010?

Trzeba zacząć od dodania do Wstążki karty Deweloper. W tym celu trzeba użyć karty Plik, zastępującej dziwaczny, okrągły Przycisk Office z wersji 2007. Karta Plik, zwana też dla zmylenia przeciwnika widokiem Backstage, pozwala oczywiście zarządzać plikiem (zapisywanie, drukowanie, właściwości itp.). Znajdziemy tu także opcje Excela. I właśnie te opcje nas teraz interesują.
Po wejściu w Opcje wybieramy Dostosowywanie Wstążki i zaptaszamy wybór karty Deweloper. Po zatwierdzeniu możemy obejrzeć nowo dodaną kartę, a na niej stare dobre przyciski ze starego dobrego paska Visual Basic (i komu on przeszkadzał?).

Tu przede wszystkim interesujemy się Bezpieczeństwem Makr, które w zdecydowanej większości przypadków powinniśmy zostawić w domyślnej opcji – Wyłącz wszystkie makra i wyświetl powiadomienie (dawny średni poziom zabezpieczeń). Pozwoli nam to na podjęcie decyzji czy włączyć makra po otwarciu pliku je zawierającego. Nawiasem mówiąc Microsoft znowu prawdopodobnie dla zmylenia przeciwnika, pozwala na podjęcie tej decyzji bądź to w wielkim oknie dialogowym, bądź to w komunikacie w formie nierzucającego się w oczy paska pojawiającego się nieśmiało nad nagłówkami kolumn.

Kolejny ruch to zapisanie pliku jako Skoroszyt programu Excel z obsługą makr, bo tylko w takim typie pliku możemy zapisać kod pod Excelem 2007/2010. I to z grubsza tyle, możemy sobie teraz nagrać i poedytować jakieś makro, czyli procedurę publiczną VBA. Możemy też napisać jakąś własną funkcję publiczną i używać jej jak funkcji wbudowanej Excela. Co bardziej ambitni mogą oprogramować zdarzenia skoroszytu czy arkusza a najbardziej wytrwali mogą nawet zaprojektować i oprogramować własny formularz. Powodzenia!
Jeszcze jedna uwaga. Gdyby przyszło nam do głowy rozpowszechniać kod w postaci szablonu musimy pamiętać aby zapisać plik jako Szablon programu Excel z obsługą makr

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

Odczyt dostępnej rozdzielczości ekranu z poziomu VBA

W celu dynamicznego dostosowania własnej aplikacji do rozdzielczości ekranu musimy tą rozdzielczość jakoś odczytać. Fajnie by było jeszcze wiedzieć, czy cały ekran jest dla nas dostępny (trzeba uwzględnić np pasek zadań). Można się tego dowiedzieć używając funkcji Windows GetSystemMetrics:

Private Declare Function GetSystemMetrics _
    Lib "user32.dll" (ByVal nIndex As Long) As Long
'--
 
Sub RozdzielczoscEkranu()
 
    'rozdzielczość nominalna
    Const POZIOMA_NOMINALNA = 0
    Const PIONOWA_NOMINALNA = 1
 
    'rozdzielczość z odliczeniem
    'paska zadań
    Const POZIOMA_DOSTEPNA = 16
    Const PIONOWA_DOSTEPNA = 17
 
    Debug.Print "POZIOMA_NOMINALNA: " & _
        GetSystemMetrics(POZIOMA_NOMINALNA)
    Debug.Print "PIONOWA_NOMINALNA: " & _
        GetSystemMetrics(PIONOWA_NOMINALNA)
    Debug.Print "POZIOMA_DOSTEPNA: " & _
        GetSystemMetrics(POZIOMA_DOSTEPNA)
    Debug.Print "PIONOWA_DOSTEPNA: " & _
        GetSystemMetrics(PIONOWA_DOSTEPNA)
 
End Sub

Sprawdzenie, czy użytkownik ustawił komórkę aktywną w zakresie danych

Często występującym problemem jest próba uruchomienia kodu wymagającego zakresu danych, w czasie gdy użytkownik:

  • nie ustawił się w zakresie danych (stoi w pustej komórce poza zakresem)
  • nie uaktywnił właściwego typu arkusza (np stoi w arkuszu typu wykres)
  • nie uaktywnił właściwego typu okna (np stoi na oknie wykresu osadzonego w arkuszu)

Tu z pomocą mogą przyjść nam 3 sprawdzające to funkcje logiczne:

Option Explicit
Public Const WERSJA = "Wykresy VBA v.0.1 (Akademia-VBA.pl)"
 
Private Function NienormalnyArkusz() As Boolean
    If ActiveSheet.Type <> xlWorksheet Then
        MsgBox "Ustaw się w arkuszu danych!", vbExclamation, WERSJA
        NienormalnyArkusz = True
    End If
End Function
 
Private Function NienormalneOkno() As Boolean
    If ActiveWindow.Type <> xlWorkbook Then
        MsgBox "Ustaw się w oknie danych!", vbExclamation, WERSJA
        NienormalneOkno = True
    End If
End Function
 
Private Function BrakZakresu() As Boolean
    If Len(ActiveCell) = 0 Then
        MsgBox "Ustaw się w niepustej komórce zakresu danych!", vbExclamation, WERSJA
        BrakZakresu = True
    End If
End Function

Takie funkcje bardzo upraszczają kod procedury głównej, w naszym przypadku uruchamiającej formularz generujący wykresy. Powinny być raczej prywatne, ponieważ nie są zbyt przydatne jako funkcje arkuszowe

Sub UruchomFormularz()
    If NienormalnyArkusz Then Exit Sub
    If NienormalneOkno Then Exit Sub
    If BrakZakresu Then Exit Sub
    fmWykresy.Show
End Sub