Akademia VBA

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

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/

Kopiowanie i linkowanie plików Worda

Kategorie: Ogólne — Darek Kolasa o 12:19, 2 Wrz 2014

Ostatnio dotknąłem się do programowania Worda. Nie było to przyjemne uczucie 😉
No ale w końcu jest to Akademia VBA a nie Akademia VBA Excel i Access 🙂
Po zaznaczeniu jakiegoś tekstu kod kopiuje aktywny plik pod nazwą jak zaznaczenie i od razu robi link do niego. Używa też fajnej funkcji do odczyszczania tekstu ze zbędnych znaków specjalnych i innych zabronionych w nazwach obiektów i plików

Sub UtworzKopiePliku_i_Link()
    Dim MojDokument As Word.Document
    Dim Kopia As Word.Document
    Dim ZaznTekst As String
    Dim SciezkaMojDokument As String
    Dim SciezkaFolder As String
 
    ZaznTekst = fnCzystyTekst(Selection.Range.Text)
    If Len(ZaznTekst) = 0 Then
        MsgBox "Brak zaznaczenia!"
        Exit Sub
    End If
    Set MojDokument = ThisDocument
    SciezkaMojDokument = MojDokument.FullName
    SciezkaFolder = MojDokument.Path & "\"
    MojDokument.Bookmarks.Add ZaznTekst, Selection
    MojDokument.Save
    MojDokument.SaveAs SciezkaFolder & ZaznTekst & ".docm"
    Set Kopia = MojDokument
    Set MojDokument = Documents.Open(SciezkaMojDokument)
    Selection.GoTo What:=wdGoToBookmark, Name:=ZaznTekst
    MojDokument.Hyperlinks.Add Anchor:=Selection.Range, _
        Address:=Kopia.Name, TextToDisplay:=ZaznTekst
 
    Set MojDokument = Nothing
    Kopia.Close
    Set Kopia = Nothing
End Sub
 
Function fnCzystyTekst(Tekst As String)
    Dim Znak As String * 1, NrZnaku As Long
    For NrZnaku = 1 To Len(Tekst)
        Znak = Mid(Tekst, NrZnaku, 1)
        If Znak Like "[A-Z,a-z,0-9,Ć,Ę,Ł,Ó,Ś,Ż,Ź,ć,ę,ł,ó,ś,ż,ź]" Then
            fnCzystyTekst = fnCzystyTekst & Znak
        End If
    Next
End Function

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

Usuwanie duplikatów

Kategorie: Excel VBA,Office 2007,Office 2010 — Dariusz Kolasa o 22:13, 27 Mar 2013

Jedną z nowości w Excelu 2007/2010 jest narzędzie do usuwania duplikatów. Bardzo przydatne np do tworzenia słowników. We wcześniejszych wersjach ten efekt można było osiągnąć za pomocą opcji filtra zaawansowanego, co nie było bardzo proste i mało kto o tym wiedział. Nowego narzędzia Usuń duplikaty da się też użyć z poziomu kodu, np:

'---
ActiveSheet.UsedRange.Columns(10).RemoveDuplicates Columns:=1, Header:=xlYes
'---

Transpozycja części kolumn zakresu

Kategorie: Excel VBA — Dariusz Kolasa o 14:20, 3 Paź 2012

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

Wartość minimalna z tablicy

Kategorie: Ogólne,Podstawy VBA — Dariusz Kolasa o 12:09, 21 Lip 2012

Ponieważ pytanie o minimalną wartość z tablicy pojawia się na forach VBA z częstotliwością semestralną, postanowiłem umieścić kawałek kodu, pomagający w rozwiązaniu problemu:

Function MinTablicy(Tablica As Variant) As Variant
    Dim WartMin As Variant
    Dim IndeksDolny As Long, IndeksGorny As Long, i As Long
    IndeksDolny = LBound(Tablica)
    IndeksGorny = UBound(Tablica)
    WartMin = Tablica(IndeksDolny)
    For i = IndeksDolny To IndeksGorny
      If Tablica(i) < WartMin Then WartMin = Tablica(i)
    Next
    MinTablicy = WartMin
End Function
 
Sub TestFunkcji()
    Dim Tablica() As Variant
    Tablica = Array(7, 3, 5, 2, 6)
    MsgBox "Minimalana wartość z tablicy to: " & MinTablicy(Tablica)
End Sub
« Późniejsze wpisyWcześniejsze wpisy »