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

Objavljeno v Pisarna Oznake:

Dodaj odgovor

Vaš e-naslov ne bo objavljen. * označuje zahtevana polja

*