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.
torek, 15. marec 2011
ponedeljek, 14. marec 2011
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
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
četrtek, 10. marec 2011
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.
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.
petek, 4. marec 2011
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
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
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
Naročite se na:
Objave (Atom)