VBA in SQL

Živimo, baje, v času recesije, zato je potrebno včasih kakšno stvar narediti po težji poti. Ena od takih, se mi je zgodila nekaj dni nazaj. Gre sicer za precej banalen primer, ki bi se ga dalo preprosto rešiti s pomočjo MS Accessa ali pa bi se preprosto programerjem plačalo, da naredijo poročilo v trenutne programu. No, ničesar od tega ni bilo, zato sem se držal reka: "pomagaj si sam in bog ti bo pomagal".

Opis problema

Program za vodenje katastrov temelji na bazi MySql, vendar nima pripravljenih določenih izpisov. Z uporabo Excela lahko sicer naredimo query, a se pri malo manj ukih uporabnikih zatakne pri nastavljanju parametrov izpisa. Navadno pride do tega, da kliknejo na bližnjico za zagon poizvedbe in potem pobrišejo vse nepotrebne vrstice (mogoče celo stolpce). Tukaj pa nam pride hitro v pomoč VBA.

Celotna skripta še ni dodelana, ampa za prvo silo deluje. Sestavljena je iz preprostega obrazca s tremi besedilnimi polji (TextBox) in dveh gumbov.

Nato pa seveda dodamo še malo besedila, ki bo naredilo nekaj pametnega.

Za gum "Išči" sledi naslednje:


Private Sub CommandButton1_Click()


'Spucamo vse podatke na delovnem listu
List1.Cells.Clear


'povezemo se z MySQL bazo
'ce dopisemo ;PASSWORD=xxxxxx;, ne rabimo vpisovat gesla po zagonu skripte
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "ODBC;DATABASE=komunala;DRIVER={MySQL ODBC 3.51 Driver};OPTION=0;;PORT=0;UID=danijel;" _
        , Destination:=Range("$A$1")).QueryTable
        .CommandText = Array( _
        "SELECT bass_pogodbe_0.ID, bass_pogodbe_0.OBCINA_SIFRA, bass_pogodbe_0.OBCINA_NAZIV, bass_pogodbe_0.KRAJ_SK_SIFRA, bass_pogodbe_0.KRAJ_SK_NAZIV, bass_pogodbe_0.ULICA_SIFRA, bass_pogodbe_0.ULICA_NAZIV, " _
        , _
        "bass_pogodbe_0.OM_HS, bass_pogodbe_0.OM_HSD, bass_pogodbe_0.OM, bass_pogodbe_0.OM_NAZIV, bass_pogodbe_0.OM_PLACNIK, bass_pogodbe_0.NAZIV, bass_pogodbe_0.NASLOV, bass_pogodbe_0.PTT, bass_pogodbe_0.KRAJ" _
        , _
        ", bass_pogodbe_0.POGODBA_STEVILKA" & Chr(13) & "" & Chr(10) & "FROM komunala.bass_pogodbe bass_pogodbe_0" & Chr(13) & "" & Chr(10) & _


'pa se pogoji, ki se nanasajo na textboxe
        "WHERE (bass_pogodbe_0.ULICA_NAZIV LIKE '%" & UserForm1.txtUlica.Text & "%' AND bass_pogodbe_0.OBCINA_SIFRA LIKE '%" & UserForm1.txtObcina.Text & "%' AND bass_pogodbe_0.OM_NAZIV LIKE '%" & UserForm1.txtOmNaziv.Text & "%' )")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .ListObject.DisplayName = "Tabela_Poizvedba_iz_mysql"
        .Refresh BackgroundQuery:=False
    End With


End Sub

Z drugim gumbom natisnemo vsebino lista:


Private Sub CommandButton2_Click()

     With ActiveSheet.PageSetup

        .PrintTitleRows = "$1:$1"

        .PrintTitleColumns = ""

    End With

Application.Dialogs(xlDialogPrint).Show

End Sub

To je nekako osnovno, kar je bilo narejeno. Po željah in zmožnostih, bomo pa dodajali tudi nove stvari.

Obrazec za vnos

Excel je zelo uporaben ko se soočimo z vnosom podatkov. Uporabimo lahko vgrajen obrazec, lahko pa si seveda izdelamo svojega. Vse skupaj je zelo preprosto in velikokrat nam precej olajša delo.

Kot vedno zaženemo VBA (Alt+F11) in vstavimo obrazec (Insert -> UserForm). Najprej se nam prikaže samo ozadje obrazca, ki ga oblikujemo po želji; vstavimo Tekstovna polja (textbox), gumbe (button), Imena (label),...

V naslednjem primeru je prikazana izdelava obrazca za vnos podatkov o prometni signalizaciji v določenem naselju.

Sama oblika obrazca je dokaj preprosta in pregledna, ker se mi ni dalo preveč ukvarjati z lepotičenjem.

Ko zaključimo z oblikovanjem obrazca, pa je potrebno dodati tudi nekaj programske kode, ki poskrbi, da postane obrazec uporaben. V oknu Project Explorer (na zgornji sliki je to levo zgornje okno) poiščemo naš obrazec (UserForm1), kliknemo nanj z desno tipko in izberemo View Code.

Vpišemo kodo, ki naj se izvede:

Private Sub Initialize()
'ob zagonu pobrišemo vsa polja v obrazcu.
    txtOdsek.Value = ""
    txtOznaka.Value = ""
    txtNaziv.Value = ""
    txtStacionaza = ""
    txtVisina = ""
    txtOpomba = ""
End Sub

Private Sub cmdIzhod_Click()
'gumb za izhod zapre obrazec
    Unload Me
End Sub

Private Sub cmdVnos_Click()
'ko kliknemo na gumb vnos, naj se vsebina obrazca vnese v prvo prazno vrstico
'na  delovnem listu "podatki"
          
    ActiveWorkbook.Sheets("podatki").Activate

    Range("A1").Select

    Do

    If IsEmpty(ActiveCell) = False Then

        ActiveCell.Offset(1, 0).Select

    End If

    Loop Until IsEmpty(ActiveCell) = True

    ActiveCell.Value = txtOdsek.Value

    ActiveCell.Offset(0, 1) = txtOznaka.Value

    ActiveCell.Offset(0, 2) = txtNaziv.Value

    ActiveCell.Offset(0, 3) = txtStacionaza.Value
  
    ActiveCell.Offset(0, 4) = txtVisina.Value
  
    ActiveCell.Offset(0, 5) = txtOpomba.Value

  
    'Range("A1").Select
    ActiveCell.Offset(1, 0).Select
End Sub

In zaženemo s tipko F5 ali pa kliknemo na  Run -> Run Sub/User Form.

Povprečje, min, max

Danes pa nekaj, kar sploh ni bilo narejeno s pomočjo VBA. Gre za kombinacijo uporaba funkcije IF in AVERAGE.

Težava, ki je iskala rešitev, je bila v tem, da so podatki lahko v 1 ali pa več stolpcev. Ker je maksimalno število stolpcev znano, sem vse skupaj naredil bolj po partizansko; samo da dela.

Glava poročila je vedno enaka in v celicah D26 do M26 je potrebno izračunat povprečje vrednosti. Ampak. Ne vemo koliko vrstic podatkov, pa tudi vsi stolpci nimajo vedno podatkov (senzor mrtev). Torej vedno preverimo, če je v dotični celici sploh zapisana vrednost, izračunamo povprečje za tisto število celic, ki imajo številske podatke. Če pa podatkov ni, se v poročilni tabeli izpiše "Ni podatkov".

=IF(N30<>0;AVERAGE(N30:(INDEX(N30:N27201; COUNT(N30:N27201))));"Ni podatkov")

Vse skupaj je dejansko preprosto kot znana srbska nacionalna jed.

Odpiranje, zapiranje, rangi,...

Naslov je čuden, pa naj bo še vsebina. Sicer nič posebnega, mi je pa vzelo nekaj uric prijetnega dela.

Začetna želja je bila, da iz podatkov nekih sond (10 temperaturnih sond), naredimo poročilo, ki vsebuje minimalno, maksimalno in povprečno vrednost odčitka ter seveda nariše graf. Nič posebnega, lahko se naredi tudi "na roke". Toda življenje ni zanimivo, če ne malo kompliciramo.

V spodnjem nakladanju manjka samo še malo lepote. V izdelku je seveda še datoteka, z logotipom, opisom, gumbom za zagon...

No, da še malo opišem, kaj sploh je to. Ko zaženemo proceduro, se odpre okno za odpiranje datoteke (s podatki), odpremo datoteko in vpraša nas po območju, ki vsebuje potrebne podatke. Označimo, kliknemo OK in že sledi drugo odpiranje datoteke. Tokrat izberemo datoteko, ki vsebuje vzorec poročila in nekaj malega funkcij (min, max, average, if...malce, nam popravi izgled). V to datoteko se kopirajo podatki, ki smo jih izbrali v prejšnji datoteki. Nato procedura še nariše graf, nas vpraša kam želimo shraniti novo poročilo ter zapre datoteko s podatki in datoteko z vzorčnim poročilom.

Sub vnos()

Dim sPorocilo As String
Dim sPodatki As String
Dim wbPodatki As Variant


'odpremo datoteko s podatki

sPodatki = Application.GetOpenFilename(fileFilter:="Excel FIles (*.xls), *.xls", _
                                        Title:="Prosim izberi datoteko s podatki")
            If sPodatki = "False" Then Exit Sub
          
Workbooks.Open Filename:=sPodatki
wbPodatki = Application.ActiveWorkbook.Name

 
'V datoteki s podatki iz termometrov izberem obseg podatkov: od ure do zadnjega temperaturnega senzorja 'oz po želji

Dim rRange As Range

On Error Resume Next
    Application.DisplayAlerts = False

    Set rRange = Application.InputBox(Prompt:="Prosim izberi obseg vhodnih podatkov", _
    Title:="Določi obseg", Type:=8)

On Error GoTo 0

    Application.DisplayAlerts = True

    If rRange Is Nothing Then
        Exit Sub

    Else
        'podatke kopiramo
        rRange.Copy

    End If

'Odpiranje izbrane xls datoteke z vzorcem porocila

sPorocilo = Application.GetOpenFilename(fileFilter:="Excel Files (*.xls), *.xls", _
                                        Title:="Prosim izberi datoteko z vzorcem poročila")
    If sPorocilo = "False" Then Exit Sub

Workbooks.Open Filename:=sPorocilo

'aktiviramo delovni zvezek in nato delovni list ter skočimo v celico C30
ActiveWorkbook.Sheets("podatki").Activate
ActiveSheet.Cells(30, 3).Activate

'prilepimo podatke
ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False


'pobrišemo odložišče
Application.CutCopyMode = False


'narišemo graf
Dim povp As Range
Dim ura As Range
Dim vrstica As Integer
Dim vrs As String
Dim vrsx As String


ActiveWorkbook.Sheets("podatki").Activate

vrstica = WorksheetFunction.Count(Range("D30", "D25000")) + 29
vrs = "N" & vrstica
vrsx = "O" & vrstica

Set povp = Range("N30", vrs)
Set ura = Range("O30", vrsx)

    ActiveWorkbook.Sheets("podatki").Select
    ActiveSheet.Shapes.AddChart.Select
    ActiveChart.ChartType = xlLine
'seveda bo grafikon poimenovan grafikon in bo na svojem listu
    ActiveChart.Location Where:=xlLocationAsNewSheet, Name:="Grafikon"
    ActiveWorkbook.Charts("Grafikon").Activate
    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.SeriesCollection(2).Name = "='podatki'!$N$29"
    ActiveChart.SeriesCollection(2).Values = povp
    ActiveChart.SeriesCollection(2).XValues = ura
    ActiveChart.SeriesCollection(1).Delete

'in shranimo datoteko

   fileSaveName = Application.GetSaveAsFilename( _
    fileFilter:="Excel Files (*.xls), *.xls")

    If fileSaveName = False Then
        Exit Sub
    End If

' Shrani datoteko v format xls
ActiveWorkbook.SaveAs Filename:= _
        fileSaveName, FileFormat:=xlExcel8, _
        CreateBackup:=False

'lepo je, če uporabniku kaj povemo
    file_name_saved = ActiveWorkbook.FullName
    MsgBox "Datototeka je shranjena: " & vbCr & vbCr & file_name_saved

'zapremo datoteko z vzorčnim poročilom in s podatki
    ActiveWorkbook.Close
    Workbooks(wbPodatki).Close


End Sub

Urejanje podatkov in zapolnitev celic

Danes sem bil soočen z zelo zanimivim izzivom. Kolega je potreboval malce statistično obdelane podatke.

Podatki obsegajo pojavljanje tornadov za mesece april, maj in junij, za tri zvezne države in še zanimivost, zbrani so za obdobje 1970 - 2010. Vsaka država je urejena na svojem listu, stolpci pa si sledijo tako: dan v mesecu, april, maj, junij, dan v mesecu, april, maj, junij, dan v mesecu,...



Najprej sem neobdelane podatke skopiral v nov zvezek in pobrisal podatke, ki me niso zanimali oziroma so me motili.


Sub brisanje()
Dim a As Integer
Dim i As Integer

    'od zadnjega stolpca pobrišemo vsak 4. stolpec
    For i = 1 To 40
        a = 165 - (4 * i)

        ActiveWorkbook.Sheets("List1").Select
        ActiveSheet.Cells(1, a).EntireColumn.Delete

    Next

End Sub


Nato sem skopiral podatke iz večih stolpcev v en sam stolpec:


Sub kopiranje()
Dim i As Integer
Dim a As Integer

    For i = 1 To 41
        a = i * 3

        'izberemo prvi stolpec z uporabnimi podatki in jih kopiramo
        ActiveWorkbook.Sheets("List1").Select
        Range(Cells(3, a), Cells(32, a)).Select
        Selection.Copy

            'prilepimo jo na nov delovni list
            ActiveWorkbook.Sheets("List2").Select
            ActiveSheet.Cells((i * 91 - 90), 2).Select
            ActiveSheet.Paste

        'spet gremo na prvi delovni list in izberemo drugi stolpec in ga kopiramo
        ActiveWorkbook.Sheets("List1").Select
        Range(Cells(3, a + 1), Cells(33, a + 1)).Select
        Selection.Copy

            'prilepomo ga na koncu prvega kopiranega stolpca
            ActiveWorkbook.Sheets("List2").Select
            ActiveSheet.Cells((i * 91 + 30 - 90), 2).Select
            ActiveSheet.Paste

        ActiveWorkbook.Sheets("List1").Select
        Range(Cells(3, a + 2), Cells(32, a + 2)).Select
        Selection.Copy

            'junij
            ActiveWorkbook.Sheets("List2").Select
            ActiveSheet.Cells((i * 91 + 61 - 90), 2).Select
            ActiveSheet.Paste

    'to naredimo za i * 41 stolpcev
    Next

End Sub


Seveda moramo podatkom pripisati še datum. Vmes so seveda tudi prestopna leta, zato ne moremo direktno uporabit funkcije =A1+365 ;)

Lahko pa naredimo tako:


Sub datumi()
Dim i As Integer

    For i = 1 To 41
      
        'izberemo prvo celico na listu 2 in vanjo vpišemo 1.4. (na angleški način)
        ActiveWorkbook.Sheets("List2").Select
        ActiveSheet.Cells((i * 91 - 90), 1).Select
        ActiveCell = "4/1/" & 1969 + i

        'nato zapolnimo vseh 90 zaporednih dni in v drugem krogu spet vpišemo 1.4. in prištejemo i-to leto
        Selection.AutoFill Destination:=Range(Cells((i * 91 - 90), 1), Cells((i * 91), 1))


    Next

End Sub



To je nekako to. Za napake pa ne odgovarjam, zato uporabljajte varnostne kopije podatkov.

Zapolnjevanje praznih celic

Velikokrat kopiramo razne tabele iz Worda (besedilni urejevalnik) v Excel, pri tem pa pride do pojava praznih celic. Tega niti ne zaznamo kot težave, dokler nismo prisiljeni teh podatkov obdelati za nadaljne analize. Sam sem imel tako težavo, ker so v "stolpcu B" (naziv naselja) bili podatki, ki sem jih potreboval za nadaljno obdelavo. Zato sem si malo pomagal z VBA

Sub zapolni()
'najde prvo prazno celico in vanjo prepiše vrednost in zadnje polne celice

Dim i As Integer

'Nastavljeno je na korak 20 vrstic, ker se to lepo vidi na eni velikosti zaslona
For i = RowCount To 20 Step 1

'Range je določen za maksimalno velikost. ni pa potrebno,ker se sam odločiš kdaj neha delat
'Trenutno je izbran stolpec B
Range("B65536").End(xlUp).Select

    Range("B1").End(xlDown).Offset(1, 0).Select
    ActiveCell.Offset(-1, 0).Copy
    ActiveCell.Offset(0, 0).PasteSpecial xlPasteAllExceptBorders

Next

End Sub

Obdelava vseh zvezkov v mapi

Vsi se srečujemo s situacijami, ko moramo pripravljati poročila za celo leto. V primeru, da imamo posamezne zvezke za določeno leto v isti mapi, nam zelo koristi manjša VBA skripta. Nastavljena je tako, da nam odpre vse delovne zvezke (workbooks) v določeni mapi (folder). Vanjo vstavimo še tisti del, ki nam podatke obdela. Nato jih skripta shrani in zapre.

Ker so Application.ScreenUpdating, Application.DisplayAlerts in Application.EnableEvents nastavljena na FALSE, nam na zaslonu nič ne poskakuje med izvajanje. Če bi pa radi izpadli bolj "geekovsko", preprosto nastavimo vse na TRUE oz. pobrišemo dotične vrstice.

Sub porocilo()
'ce ne dela moras dat reference microsoft word object

'Dimi za word
Dim wrdApp As Word.Application
Dim xlsAPP As Excel.Application

'Dimi za odpiranje vseh excelovih datotek v mapi
Dim lCount As Long
Dim wbResult As Workbook
Dim wbCodeBook As Workbook

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

'ustvari objekt MS Word. Odpre se program MS WORD
Set wrdApp = CreateObject("Word.Application.12")
    wrdApp.Visible = True
  
    'Ustvari nov Wordov dokument
    wrdApp.Documents.Add

'odpiranje vseh excelovih datotek v mapi
On Error Resume Next
    Set wbCodeBook = ThisWorkbook
        With Application.FileSearch
            .NewSearch
            'Spremeni pot, da ustreza
            .LookIn = "\delo"
            .FileType = msoFileTypeExcelWorkbooks
            'Pogojni filter za vremenske datoteke
            .Filename = "wd*.xls"
                If .Execute > 0 Then 'za delovne zvezke v mapi
                    For lCount = 1 To .FoundFiles.Count 'loopa skozi vse
                        'odpri zvezek x in ji priredi spremenljivko Workbook
                        Set wbResult = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
                      
                        'tukaj bo koda za izdelavo vseh potrebnih grafov in tabel
                      
                      
                      
                        'in seveda še zaključek multiplega odpiranja zvezkov
                        wbResult.Close SaveChanges:=False
                    Next lCount
                End If
            End With
        On Error GoTo 0
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
  
End Sub