Archiwum kategorii: Excel VBA

Lista wszystkich arkuszy i wykresów

Opublikowany przez
Odpowiedz

Zadanie trywialne ale można się zafiksować na pętlę For Each, która w tym wypadku nie zadziała, gdyż mamy tu 2 typy obiektów: Worksheet i Chart
W związku z tym trzeba użyć tradycyjnej pętli z indeksem arkusza

Sub ListujArkuszeOrazWykresy()
    Dim NrArk As Long
    For NrArk = 1 To ThisWorkbook.Sheets.Count
        Debug.Print ThisWorkbook.Sheets(NrArk).name
    Next
End Sub

VBA Excel ColorIndex

Opublikowany przez
Odpowiedz

Bardzo często potrzebujemy wrzucić kolor do komórki. Najprościej i najwydajniej działa użycie ColorIndex
Poniżej kod i jego efekt

Sub LegendaColorIndex()
    If ActiveSheet.UsedRange.Cells.Count > 1 Then
        MsgBox "Zanim uruchomisz makro tworzące legendę ColorIndex ustaw się w pustym arkuszu", vbInformation, "STOP"
        Exit Sub
    End If
 
    Dim W As Long, K As Long
    For W = 1 To 7
        For K = 1 To 8
            Cells(W, K).Value = (W - 1) * 8 + K
            Cells(W, K).Interior.ColorIndex = (W - 1) * 8 + K
            Select Case Cells(W, K).Value
                Case 1, 5, 9, 10, 11, 12, 13, 14, 16, 18, 21, 23, 25, 29, 30, 31, 32, 47, 49, 51, 52, 53, 54, 55, 56
                    Cells(W, K).Font.ColorIndex = 2
            End Select
        Next
    Next
    Dim Zakres As Range
    Set Zakres = ActiveSheet.UsedRange
    Zakres.Font.Bold = True
    Zakres.HorizontalAlignment = xlCenter
    Zakres.VerticalAlignment = xlCenter
    Zakres.RowHeight = 30
End Sub

Słownie z groszami w postaci ułamka

Opublikowany przez
11

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

ADOX

Opublikowany przez
Odpowiedz

Bardzo stara i bardzo fajna biblioteka do obsługi struktury bazy. Na liście referencji nazywa się Microsoft ADO Ext. XX for DDL and Security. Potrzebna jest też biblioteka ADO do nawiązania połączenia. Kluczowy jest ADOX.Catalog, który pozwala na iterowanie po tabelach, polach itp.
Poniższy kod wymaga tzw. connection string (stała CN_STR), których przykłady są w artykule o ADO – i wszystkie bazy są nasze

Sub Lista_Tabel_Kolumn()
    Dim cn As New ADODB.Connection
    Dim cat As New ADOX.Catalog
    Dim tb As ADOX.Table
    Dim k As ADOX.Column
 
    cn.ConnectionString = CN_STR 'dodaj swoje ustawienia!
    cn.Open
 
    Set cat.ActiveConnection = cn
 
    For Each tb In cat.Tables
        For Each k In tb.Columns
            Debug.Print tb.Name, k.Name
        Next
    Next
End Sub

Funkcja do sprawdzania sprawdzania poprawności

Opublikowany przez
Odpowiedz

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

Sumuj wartości z kolorowych komórek

Opublikowany przez
2

Dzisiaj prosta wprawka z użyciem pętli For Each
Zaznaczamy zakres a makro zsumuje wartości z komórek wypełnionych dowolnym kolorem

Sub SumujKolorowe()
    Dim Kom As Range
    Dim Wynik As Double
    Dim Nic As String
    For Each Kom In Selection
        If Kom.Interior.ColorIndex <> xlNone Then
            Wynik = Wynik + Kom.Value
        End If
    Next
    Nic = _
        InputBox("W polu poniżej jest suma wartości znalezionych w kolorowych komórkach :)" _
        & vbNewLine & _
        "Możesz skopiować ten wynik (Ctrl+C) aby później go gdzieś wkleić", , Wynik)
End Sub

Warunkowe usuwanie wierszy

Opublikowany przez
Odpowiedz

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

ADO – i wszystkie bazy są nasze :)

Opublikowany przez
1

Od 2000 roku czyli już od ponad 20 lat Microsoft Office może bez problemu łączyć się w zasadzie z dowolnymi bazami danych, dzięki bibliotece ADO (Microsoft ActiveX Data Object XX Library). I od tych samych ponad 20 lat budzi to niezmiennie zdziwienie wśród moich klientów i studentów. Jak to? Excel może pobrać dane z Oracle?, SQL Servera? O! Może nawet je edytować?! No oczywiście, że może, i to od wielu lat…
Biblioteka ADO (w kodzie widoczna jako ADODB) jest domyślnie podłączana tylko w Accessie. We wszystkich innych produktach, w tym w Excelu trzeba ją wybrać w referencjach. Tools – References – Microsoft ActiveX Data Object XX Library, gdzie XX to numer wersji biblioteki, ja osobiście wybieram zwykle wersję 2.8
Drugi warunek to oczywiście poprawnie zainstalowany sterownik OLEDB do określonej bazy (http://en.wikipedia.org/wiki/OLE_DB_provider)

Poniżej przykład pobierający do Excela dane z Accessa 2003, ale uważny czytelnik zobaczy drogę pobierania z Accessa 2007/10/13/16/19 tudzież z SQL Servera. Wystarczy podmienić wartość właściwości ConnectionString obiektu Connection

Option Explicit
Public Const WERSJA As String = "ADO Klient v.0.1"
Public Const ARK_DANE As String = "Dane"
Public Const ZRODLO As String = "tbBrutto"
 
'Załozenia:
' - mamy arkusz o nazwie "Dane"
' - mamy bazę PodstawyVBA.mdb a w niej tabelę tbBrutto
' - mamy sterownik do mdb
 
'Access mdb
'==========
Public Const CN_STR As String = _
    "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=D:\kursy\AC04\PodstawyVBA.mdb;" & _
    "Persist Security Info=False"
 
 
'Ponizej przykłady konfiguracji dla innych baz
 
'Access accdb
'============
'Public Const CN_STR As String = _
    "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=D:\kursy\AC04\PodstawyVBA.accdb;" & _
    "Persist Security Info=False"
 
'SQL Server
'==========
'Public Const CN_STR As String = _
    "Provider=SQLOLEDB.1;Integrated Security=SSPI;" & _
    "Persist Security Info=False;" & _
    "Initial Catalog=Produkcyjna;" & _
    "Data Source=SKARBEKMC\SQLEXPRESS"
 
 
Sub OdczytDoExcela()
    Dim Zakres As Range
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
 
    On Error GoTo Obsluga
 
    Sheets(ARK_DANE).Select
    Range("A1").Select
    Set Zakres = _
        Sheets(ARK_DANE).Range("A1").CurrentRegion
    Zakres.ClearContents
 
    cn.ConnectionString = CN_STR
    cn.Open
    rs.Open ZRODLO, cn
    Sheets(ARK_DANE).Range("A2").CopyFromRecordset rs
 
    'nagłówki
    Dim LK As Long, K As Long
    LK = rs.Fields.Count
    For K = 1 To LK
        Sheets(ARK_DANE).Cells(1, K) = rs.Fields(K - 1).Name
    Next
 
    Zakres.EntireColumn.AutoFit
 
Czyszczenie:
    On Error Resume Next
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
    Exit Sub
Obsluga:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, WERSJA
    Resume Czyszczenie
End Sub

Jak zablokować wklejanie do komórek z ustawionym sprawdzaniem poprawności

Opublikowany przez
4

Nie jest to specjalnie prosta ani ładna procedura, ale działa 🙂
Jak widać powinna być umieszczona w module prywatnym arkusza
Powoduje ona wykrycie i cofnięcie wklejania do komórek z ustawionym sprawdzaniem poprawności

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim BylaZmiana As Boolean
    Dim ZakresWspolny As Range
    On Error GoTo Obsluga
 
    'jeśli to spowoduje błąd to nie ma zmian w chronionym zakresie A1:A2
    Application.Intersect(Me.Range("A1:A2"), Target).Select
    BylaZmiana = True
 
    'ta linia prawdopodobnie spowoduje błąd gdy było wklejanie
    If Target.Validation.Type <> xlValidateDate Then Resume Next
 
Czyszczenie:
    On Error Resume Next
    Application.EnableEvents = True
    Exit Sub
Obsluga:
    Select Case Err
        Case 91
            'prawdopodobnie do zignorowania
        Case 1004
            If BylaZmiana Then
                'prawdopodobnie błąd spowodowany wklejeniem w chronionym zakresie
                MsgBox "Nie wolno niszczyć sprawdzania poprawności!", vbExclamation
                Application.EnableEvents = False
                Application.Undo
                Application.EnableEvents = True
            End If
        Case Else
            MsgBox Err & " - " & Err.Description, vbCritical
    End Select
    Resume Czyszczenie
End Sub