Archiwa tagu: Programowanie VBA

Słownie z groszami w postaci ułamka

Opublikowany przez
10

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

Akademia VBA – Oferta

Wyróżnione

Opublikowany przez
Odpowiedz

Tworzę i naprawiam aplikacje VBA/SQL/Makra. Moje aplikacje wyróżnia:

  • Dopasowanie do potrzeb klienta
  • Otwarty i dobrze skomentowany kod źródłowy
  • Instrukcja obsługi aplikacji
  • Szkolenia umożliwiające rozwijanie aplikacji własnymi siłami.

Mam 25 lat doświadczenia w szkoleniach i tworzeniu aplikacji dla biznesu. Tworzę aplikacje głównie w oparciu o środowisko Excel i VBA ale także SQL Server, Access i Power BI.

Pozdrawiam i zapraszam do współpracy

Dariusz Kolasa

Proste w użyciu operacje na plikach

Opublikowany przez
1

Mało kto wie, że VBA ma fajne i proste w użyciu funkcje do odczytywania podstawowych informacji o pliku. Poniżej przykłady wykonania z debuggera:

?FileDateTime("C:\Users\dariu\Desktop\kotek.png")
2018-10-30 21:14:47

Oczywiście zwraca datę ostatniej modyfikacji pliku

?FileLen("C:\Users\dariu\Desktop\kotek.png")
135590

Zwraca wielkość pliku w bajtach.

Także znajomość niezwykle praktycznej funkcji FileCopy jest mocno ograniczona. Jej działanie jest chyba jasne 🙂

FileCopy "C:\Users\dariu\Desktop\kotek.png", _
        "C:\Users\dariu\Desktop\kotek2.png"

Usuwanie niedozwolonych znaków w nazwie pliku

Opublikowany przez
2

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

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

Transpozycja części kolumn zakresu

Opublikowany przez
1

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

Deklaracja zmiennych

Opublikowany przez
4

Dla początkujących użytkowników VBA nieodmiennie zagadką jest deklarowanie zmiennych. Po pierwsze w ogóle nie wiadomo po co to pisać, skoro bez tego i tak działa, a po drugie nazwy typów zmiennych nie brzmią zbyt przyjaźnie.
Niestety brak stosowania i rozumienia deklaracji jest głównym powodem błędów, literówek, spowolnienia działania kodu i niewygody jego pisania. Temat nie jest bardzo prosty, ale bardzo ważny. Tu krótko wymienię zalety rozumienia i stosowania właściwych deklaracji:

  • Kod działa nawet do 4 razy szybciej
  • Łatwiej pisać kod bo zmienne zadeklarowane są wspomagane przez technologię podpowiadania słów kluczowych – Intellisense
  • Unikamy literówek
  • Piszemy kod wysokiej jakości pozwalający na szybsze wychwytywanie błędów – np niezgodność typu co przy przeoczeniu może prowadzić do negatywnych konsekwencji
  • Poprawiamy czytelność kodu

Problem polega na tym, że ta wiedza przychodzi z czasem, a tego jak zwykle wszystkim brakuje …

Generowanie Tabel Przestawnych – Excel 2007/2019

Opublikowany przez
1

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" &amp; OstW &amp; "C" &amp; 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

Bezpieczne wyłączenie odświeżania ekranu

Opublikowany przez
Odpowiedz

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

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

Opublikowany przez
10

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