Akademia VBA

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

Funkcja do sprawdzania sprawdzania poprawności

Kategorie: Excel VBA — Darek Kolasa o 8:56, 26 Lip 2018

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

Kategorie: Excel VBA,Podstawy VBA — Darek Kolasa o 10:15, 11 Sty 2017

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

Kategorie: Excel VBA,Podstawy VBA,Uniwersalne VBA — Darek Kolasa o 19:17, 22 maja 2015

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 :)

Kategorie: Access VBA,Excel VBA,Office VBA,SQL Server — Darek Kolasa o 14:36, 23 Gru 2014

Od 2000 roku czyli już od kilkunastu 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 kilkunastu 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 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

Piszą o mnie :)

Kategorie: Excel VBA — Darek Kolasa o 20:03, 19 Gru 2014

Ostatnio zaprzyjaźniony blog się o mnie wypowiedział 😉
http://malinowyexcel.pl/jak-zamienic-kropki-na-przecinki-za-pomoca-makra-vba/

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

Kategorie: Excel VBA,Ogólne — Darek Kolasa o 15:40, 21 maja 2014

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

Odświeżanie nazwanych zakresów

Kategorie: Excel VBA — Darek Kolasa o 11:20, 2 Kwi 2014

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

Usuwanie fragmentów tekstu ograniczonego parą znaków

Kategorie: Excel VBA,Podstawy VBA — Darek Kolasa o 20:40, 22 Gru 2013

Ostatnio dwukrotnie zostałem poproszony o rozwiązanie problemu usuwania części tekstu pomiędzy parą znaków
Np „Ala (hihi) ma kota (hehe) a kot to” – powinno zostać zamienione na „Ala ma kota a kot to”
Oto rozwiązanie, pisane jak zwykle na szybko, więc pewnie ktoś już to kiedyś zrobił lepiej 🙂

' Wymaga biblioteki Excela
' ze względu na obiekt WorksheetFunction
Function PominTekst( _
    Tekst As String, Ogr1 As String, Ogr2 As String, _
    BezZbednychSpacji As Boolean)
 
    Dim Pocz As Long, Wynik As String
    Dim PozOgr1 As Long
    Dim PozOgr2 As Long
    Pocz = 1
    Do
        PozOgr1 = InStr(Pocz, Tekst, Ogr1)
        If PozOgr1 = 0 Then Exit Do
        PozOgr2 = InStr(PozOgr1 + 1, Tekst, Ogr2)
        Wynik = Wynik & Mid(Tekst, Pocz, PozOgr1 - Pocz)
        Pocz = PozOgr2 + 1
    Loop
    Wynik = Wynik & Mid(Tekst, Pocz)
    If BezZbednychSpacji Then
        PominTekst = WorksheetFunction.Trim(Wynik)
    Else
        PominTekst = Wynik
    End If
End Function

Pobieranie pliku ze strony WWW

Kategorie: Excel VBA — Darek Kolasa o 16:48, 12 Lis 2013

Można tego dokonać całkiem prosto:

 
Sub PobierzPlik()
Dim Link As String
Link = "http://serwer.pl/pliki/katalog.csv"
ActiveWorkbook.FollowHyperlink Address:=Link, NewWindow:=True
End Sub

Usuwanie wybranych obiektów z kolekcji OLEObjects

Kategorie: Excel VBA — Dariusz Kolasa o 14:58, 10 Cze 2013

Jak się okazuje Excel nadaje się do wszystkiego 🙂 Ostatnio troszeczkę pomogłem przy aplikacji, gdzie Excel występował w roli kontenera na różne pliki (może OneNote byłby tu lepszy?). W każdym razie był problem z usuwaniem grupy plików tego samego typu bez względu na wersję (dokładnie chodziło o pliki Worda). Sprawa okazała się dość prosta, po znalezieniu właściwości progID, zwracającej ślicznego stringa z nazwą i wersją aplikacji, np:
PowerPoint.Show.8
Word.Document.8
Word.Document.12
Excel.Sheet.8

W związku z tym wystarczyło użyć For Each .. Next dla kolekcji OLEObjects i użyć w warunku usuwania prostej funkcji tekstowej left:

Private Sub pUsun_Click()
    Dim OLEOb As Excel.OLEObject
 
    For Each OLEOb In ActiveSheet.OLEObjects
        If Left(OLEOb.progID, 4) = "Word" Then OLEOb.Delete
    Next
 
    Set OLEOb = Nothing
End Sub
Wcześniejsze wpisy »