Usuwanie fragmentów tekstu ograniczonego parą znaków

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

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

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

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

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.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

Sprawdzenie dostępności pliku

Czasem chcielibyśmy wiedzieć, czy plik na którym chcemy wykonać jakąś operację, jest dla nas dostępny. Np gdy jest otwarty przez innego użytkownika próba jego użycia może powodować błąd. Ponadto wcześniej należy sprawdzić czy dany plik w ogóle istnieje. Można to sprawdzić przy pomocy poniższych funkcji:

Public Const WERSJA as String = "Dostępność pliku v.0.1"
Sub TestFunkcji()
    Const NAZWA_PLIKU As String = "C:\EX04\Baza.xls"
    If BrakPliku(NAZWA_PLIKU) Then Exit Sub
    If PlikNiedostepny(NAZWA_PLIKU) Then Exit Sub
    MsgBox "Plik jest dostępny, można coś z nim robić ;)", vbInformation
End Sub
 
Function PlikNiedostepny(NazwaPliku As String) As Boolean
    Dim NrPliku As Long
 
    On Error GoTo Obsluga
 
    NrPliku = FreeFile()
    Open NazwaPliku For Binary Access Read Write Lock Read Write As #NrPliku
    Close #NrPliku
    Exit Function
Obsluga:
    Select Case Err
    Case 70
        MsgBox "Plik jest obecnie otwarty przez inny proces", vbExclamation
    Case Else
        MsgBox "Przy próbie otwarcia pliku zgłaszany jest błąd: " _
            & Err & " - " & Err.Description, vbCritical
    End Select
    PlikNiedostepny = True
End Function
 
Function BrakPliku(PelnaNazwaPliku As String) As Boolean
    If Dir(PelnaNazwaPliku) = "" Then
        MsgBox "Brak pliku", vbCritical, WERSJA
        BrakPliku = True
    End If
End Function

Generowanie Tabel Przestawnych – Excel 2007/2019

Generując tabelę przestawną z poziomu kodu pod Excelem 2003 można było jako argumentu Source metody tworzącej PivotCache podać dowolny poprawnie zdefiniowany obiekt Range, np CurrentRegion lub UsedRange. Podobnie rzecz ma się pod Excelem 2007/2019 (pamiętajmy tylko o użyciu metody PivotCaches.Create zamiast PivotCaches.Add). Niestety okazuje się, że w momencie gdy obiekt Range ma liczbę wierszy przekraczającą 65 536 (co teoretycznie nie powinno być problemem pod Excelem 2007/2010) metoda generuje błąd nr 13 Type mismatch 🙁 Rozwiązaniem (niezbyt eleganckim ale innego chyba nie ma) tego problemu jest użycie zamiast obiektu Range klasycznego stringa R1C1 z tymże zakresem:

    Dim OstW As Long
    Dim OstK As Long
    Dim strZakres As String
    Dim PC as PivotCache
 
    OstW = Cells(ArkDane.Rows.Count, 1).End(xlUp).Row
    OstK = Cells(1, ArkDane.Columns.Count).End(xlToLeft).Column
    strZakres = "R1C1:R" & OstW & "C" & OstK
    Set PC = ActiveWorkbook.PivotCaches.Create( _
        SourceType:=xlDatabase, _
        SourceData:=strZakres, _
        Version:=xlPivotTableVersion14)

Przy okazji możemy zapoznać się z powszechnie znanymi wyrażeniami zwracającym nr ostatniego wiersza i ostatniej kolumny w zakresie danych

Przykład bazuje na stronie z MS Answers: http://answers.microsoft.com/en-us/office/forum/office_2010-customize/pivotcache-type-mismatch-error-when-65536-rows/0827889e-b671-e011-8dfc-68b599b31bf5?msgId=4e3a2b20-7a72-e011-8dfc-68b599b31bf5

Funkcja do liczenia stażu w latach – PelneLata

Generalnie robi to samo co excelowa DATA.RÓŻNICA ale jest łatwiejsza w użyciu, bo nie trzeba podawać interwału, no i podpowiada nazwy argumentów

Function PelneLata(DataPocz As Date, DataKon As Date) As Long
   '----------------------------------------------
    ' Mam nadzieję, że robi to samo co
    ' DATA.RÓŻNICA ale za to podpowiada argumenty :)
    '----------------------------------------------
    Dim RokPocz As Long, MiesPocz As Long, DzienPocz As Long
    Dim RokKon As Long, MiesKon As Long, DzienKon As Long
 
    If DataKon <= DataPocz Then
        PelneLata = 0
        Exit Function
    End If
 
    RokPocz = Year(DataPocz)
    RokKon = Year(DataKon)
    MiesPocz = Month(DataPocz)
    MiesKon = Month(DataKon)
    DzienPocz = Day(DataPocz)
    DzienKon = Day(DataKon)
 
    PelneLata = RokKon - RokPocz
    If MiesPocz > MiesKon Then
        PelneLata = PelneLata - 1
        Exit Function
    End If
    If MiesKon = MiesPocz Then
        If DzienPocz > DzienKon Then PelneLata = PelneLata - 1
    End If
End Function

Bezpieczne wyłączenie odświeżania ekranu

Większość programistów VBA wie o tym, że aby przyspieszyć wykonanie procedury warto wyłączyć odświeżanie ekranu. Ma to kluczowe znaczenie np. przy generowaniu złożonych wykresów.
[cc lang=”vb”] Application.ScreenUpdating = False [/cc]
Ale już nie każdy potrafi napisać kod gwarantujący przywrócenie odświeżania. Brak odświeżania może drogo kosztować…
Należy to zrobić w sekcji czyszczenia obsługi błędów, wtedy wykona się zawsze, nawet po błędzie.

Sub GenerujWykres()
   'jakieś deklaracje
   On Error GoTo Obsluga
   Application.ScreenUpdating = False
   'jakiś kod
Czyszczenie:
   On Error Resume Next
   'jakieś inne sprzątanie
   Application.ScreenUpdating = True
   Exit Sub
Obsluga:
   MsgBox Err.Description
   Resume Czyszczenie
End Sub

Oczywiście w ten sposób powinniśmy obsłużyć wszystkie inne niebezpieczne zmiany dokonane przez aplikację na maszynie użytkownika. Na szczęście obsługi błędów nie trzeba pisać w podprocedurach, wystarczy ją napisać w procedurze głównej

Nazwa pliku z pełnej ścieżki

Czasem potrzebujemy samej nazwy pliku a mamy w zmiennej pełną ścieżkę. Oczywiście sprawa jest prosta ale lepiej mieć pod ręką stosowną funkcję:

Function NazwaPlikuZeSciezki(Sciezka As String) As String
    Dim OstatniUkosnik As Long
    OstatniUkosnik = InStrRev(Sciezka, "\")
    NazwaPlikuZeSciezki = Mid(Sciezka, OstatniUkosnik + 1)
End Function