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
