Automatsko sortiranje popisa po grupama i
kopiranje tj. grupiranje po grupama uz izbor MIN i MAX broja
U ovom primjeru imamo situaciju sa dva
radna lista (Sheeta).
- Sheet1
- baza
U Sheetu "baza" nalaze nam se
podaci (broj i ime osobe). Određenom broju pridružujemo ime
neke osobe. Nakon upisa bilo kojeg broja svi podaci nam se
automatski sortiraju nakon pritiska na tipku Enter. Svi
podaci podijeljeni su u četiri grupe a svaka grupa ima 13
članova.
Na ranom listu "Sheet1" nalaze nam
se grupe od po 13 članova u stupcima B i C koji se
automatski povlače sa sheeta "baza" (linkani su). Čim
promijenimo podatke na sheeetu "baza" automatski se ti
podaci mijenjaju na Sheet1. Nadalje postoje granice MIN i
MAX brojeva koji su nam uvjeti za filtriranje tj. kopiranje.
Dakle pomoću MIN i MAX želimo sve brojeve sa pripadajućim
imenima kopirati u određenu pripadajuću grupu a glavni uvjet
je broje redoslijeda u sheetu "baza". jednom riječju zadatak
je "kiopiraj sve brojeve i imena koji se nalaze između
definiranih brojeva MIN i MAX " za svaku grupu posebno. Uz
to želimo da eventualnom promjenom i naknadnim izmjenama
automatski imamo promjene i u grupama na "Sheet1".
U koliko dobijete nekakvu grešku, znači da
niste upisali ispravan broj za MIN ili MAX ili niste
kliknuli na button COPY.
Na slijedeće tri slike uočite gore opisano
SHEET
"BAZA"
Idemo prvo riješiti Sheet "baza".
U njega umetnimo Macro koji se nalazi ispod slike. Ovaj
Macro automatski sortira sve redove u rasponu
B2:C53 prema brojevima koji
se nalaze u stupcu "B" počevši sa ćelijom B2. Nakon
sortiranja brojeva automatski nam se sortiraju i pripadajuća
imena uz određeni broj. Redni brojevi ostaju poredani kako
su i bili (uzlazno)
Makronaredba za Sheet "baza".
Kopirajte ovaj VBA code direktno u Sheet "baza".
Desni klik mišem na naziv Sheeta "baza"
=> View Code i zalijepite makronaredbu u Window Code u VBE.
----------------------------------------------------
Private Sub Worksheet_Change(ByVal
Target As Range)
Application.ScreenUpdating = False
On Error Resume Next
Range("B2:C53").Select 'range
za sortiranje
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortNormal
Target.Offset(1, 0).Select
'pozicionira se jednu ćeliju ispod nakon promjene broja u
stupcu B
Application.ScreenUpdating = True
End Sub
----------------------------------------------------
SHEET
"SHEET1"
Idemo sada riješiti Sheet "Sheet1"
Ovaj Sheet1 MORA biti
UVIJEK prvi po redu u radnoj knjizi (Workbook), inače
neće ispravno grupirati MIN i MAX
Pomoću Macroa koji se nalaze u Module1
vršimo kopiranje prema uvjetima za MIN i MAX za svaku grupu
posebno.
Dakle u Module1 umetnimo ove 4
makronaredbe (to je u stvari jedna te ista makronaredba
umnožena četiri puta) a ove makronaredbe-procedure pozivamo
preko buttona COPY. Ovaj Macro se može iskombinirati
jednostavnije ali to ostavljam vama za istraživanje i
proučavanje.
Kako se insertira Module u VBE pogledajte na linku
Insert Module u VBE.
----------------------------------------------------
Sub KopirajA()
ActiveSheet.Unprotect 'ukida
password na Sheetu1
Application.ScreenUpdating = False
Sheets(1).Range("I2:I14").ClearContents
'prazni prethodno kopirano na Sheet1 u
rasponu I2:I14
Dim rp As Double, rz As Double, rpRow As Double, rzRow As
Double
Dim aMIN As Range, aMAX As Range, rng As Range
rp = Sheets(1).Range("F1").Value
' MIN
rz = Sheets(1).Range("F2").Value
' MAX
Set rng = Sheets(1).Range("B2:B14")
'PODRUCJE PRETRAGE
If rp > rz Then Exit Sub 'ako
je MIN > MAX prekida proceduru
On Error Resume Next 'ignorira
gresku ako se zada nepostojeci MIN ili MAX
For Each aMIN In rng 'trazi MIN
If aMIN.Value = rp Then rpRow = aMIN.Row
'broj reda gdje je nadjen MIN
Next
For Each aMAX In rng 'trazi MAX
If aMAX.Value = rz Then rzRow = aMAX.Row
'broj reda gdje je nadjen MAX
Next
Range("C" & rpRow & ":" & "C" & rzRow).Copy
'PODRUCJE ZA KOPIRANJE
Range("I2").PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'PODRUCJE ZA LJEPLJENJE
Application.CutCopyMode = False
'ukida kopiranje
Set rng = Nothing 'oslobadja
varijablu rng
Range("F1").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True 'postavlja
blanko password na Sheetu1
ActiveSheet.EnableSelection = xlUnlockedCells
'dozvoljava selekciju nezakljucanih
celija
End Sub
Sub KopirajB()
ActiveSheet.Unprotect 'ukida
password na Sheetu1
Application.ScreenUpdating = False
Sheets(1).Range("I15:I27").ClearContents
'prazni prethodno kopirano
Dim rp As Double, rz As Double, rpRow As Double, rzRow As
Double
Dim aMIN As Range, aMAX As Range, rng As Range
rp = Sheets(1).Range("F15").Value
' MIN
rz = Sheets(1).Range("F16").Value
' MAX
Set rng = Sheets(1).Range("B15:B27")
'PODRUCJE PRETRAGE
If rp > rz Then Exit Sub 'ako
je MIN > MAX prekida proceduru
On Error Resume Next 'ignorira
gresku ako se zada nepostojeci MIN ili MAX
For Each aMIN In rng 'trazi MIN
If aMIN.Value = rp Then rpRow = aMIN.Row
'broj reda gdje je nadjen MIN
Next
For Each aMAX In rng 'trazi MAX
If aMAX.Value = rz Then rzRow = aMAX.Row
'broj reda gdje je nadjen MAX
Next
Range("C" & rpRow & ":" & "C" & rzRow).Copy
'PODRUCJE ZA KOPIRANJE
Range("I15").PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'PODRUCJE ZA LJEPLJENJE
Application.CutCopyMode = False
'ukida kopiranje
Set rng = Nothing 'oslobadja
varijablu rng
Range("F15").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True 'postavlja
blanko password na Sheetu1
ActiveSheet.EnableSelection = xlUnlockedCells
'dozvoljava selekciju nezakljucanih
celija
End Sub
Sub KopirajC()
ActiveSheet.Unprotect 'ukida
password na Sheetu1
Application.ScreenUpdating = False
Sheets(1).Range("I28:I40").ClearContents
'prazni prethodno kopirano
Dim rp As Double, rz As Double, rpRow As Double, rzRow As
Double
Dim aMIN As Range, aMAX As Range, rng As Range
rp = Sheets(1).Range("F28").Value
' MIN
rz = Sheets(1).Range("F29").Value
' MAX
Set rng = Sheets(1).Range("B28:B40")
'PODRUCJE PRETRAGE
If rp > rz Then Exit Sub 'ako
je MIN > MAX prekida proceduru
On Error Resume Next 'ignorira
gresku ako se zada nepostojeci MIN ili MAX
For Each aMIN In rng 'trazi MIN
If aMIN.Value = rp Then rpRow = aMIN.Row
'broj reda gdje je nadjen MIN
Next
For Each aMAX In rng 'trazi MAX
If aMAX.Value = rz Then rzRow = aMAX.Row
'broj reda gdje je nadjen MAX
Next
Range("C" & rpRow & ":" & "C" & rzRow).Copy
'PODRUCJE ZA KOPIRANJE
Range("I28").PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False,
Transpose:=False 'PODRUCJE ZA
LJEPLJENJE
Application.CutCopyMode = False
'ukida kopiranje
Set rng = Nothing 'oslobadja
varijablu rng
Range("F28").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True 'postavlja
blanko password na Sheetu1
ActiveSheet.EnableSelection = xlUnlockedCells
'dozvoljava selekciju nezakljucanih
celija
End Sub
Sub KopirajD()
ActiveSheet.Unprotect 'ukida
password na Sheetu1
Application.ScreenUpdating = False
Sheets(1).Range("I41:I53").ClearContents
'prazni prethodno kopirano
Dim rp As Double, rz As Double, rpRow As Double, rzRow As
Double
Dim aMIN As Range, aMAX As Range, rng As Range
rp = Sheets(1).Range("F41").Value
' MIN
rz = Sheets(1).Range("F42").Value
' MAX
Set rng = Sheets(1).Range("B41:B53")
'PODRUCJE PRETRAGE
If rp > rz Then Exit Sub 'ako
je MIN > MAX prekida proceduru
On Error Resume Next 'ignorira
gresku ako se zada nepostojeci MIN ili MAX
For Each aMIN In rng 'trazi MIN
If aMIN.Value = rp Then rpRow = aMIN.Row
'broj reda gdje je nadjen MIN
Next
For Each aMAX In rng 'trazi MAX
If aMAX.Value = rz Then rzRow = aMAX.Row
'broj reda gdje je nadjen MAX
Next
Range("C" & rpRow & ":" & "C" & rzRow).Copy
'PODRUCJE ZA KOPIRANJE
Range("I41").PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'PODRUCJE ZA LJEPLJENJE
Application.CutCopyMode = False
'ukida kopiranje
Set rng = Nothing 'oslobadja
varijablu rng
Range("F1").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True 'postavlja
blanko password na Sheetu1
ActiveSheet.EnableSelection = xlUnlockedCells
'dozvoljava selekciju nezakljucanih
celija
End Sub
----------------------------------------------------
Također insertirajmo Module2 i u njega
kopirajmo Macro koji se nalazi ispod slike da bi pozvali sve
četiri procedure nakon postavljanja MIN i MAX vrijednosti
Ovaj Macro poziva procedure iz Module1
redoslijedom kako su postavljene.
-------------------
Sub Kopiranje()
Call KopirajA
'poziva proceduru A iz Module1
Call KopirajB
Call KopirajC
Call KopirajD
End Sub
-------------------
SHEET1 - FORMULE
U Sheet1 u stupcu "B" postavimo formulu
=baza!B2 i kopirajmo je
prema dolje do zadnjeg reda (row 53). Ili selektirajte
stupac "B" na Sheetu "baza" pa na Copy, prebacimo se na
Sheet1 pa => Paste Special => Paste Link. Isto to uradite i
za stupac "C".
Na istom Sheetu1 obratite pažnju na stupac "D".
Ovi brojevi "ljubičaste" boje su inače na završetku
aplikacije obojani "bijelom" bojom da se ne vide
(uočite da ih nema na drugoj i trećoj slici po redu, ovog
tutorijala). On nam služe kao pomoćni element. Dakle u
stupcu D upisujemo formulu =B2
što je isti podatak kao i u ćeliji B2 a služi nam da ga
možemo uvrstiti u Vlookup formulu. Kopirajte formulu do
kraja 53 reda a nakon toga selektirajte raspon D2:D53 i
obojajte u BIJELI font
U stupcu H koristiti ćemo funkciju
VLOOKUP. Formula
koja se nalazi u stupcu "H".
=IF(I2<>"";VLOOKUP(I2;$C$2:$D$14;2;FALSE);"")
Ona nam služi da identificira pripadajući "BROJ" za dotično
IME iz "baze" koje se nalazi pored nje a koje opet formira
Makronaredba. Kopirajte formulu do kraja reda 14. U ovoj
Vlookup formuli uočite različite raspone pretraživanja.
Za drugu grupu u istom stupcu postavite formulu
=IF(I15<>"";VLOOKUP(I15;$C$15:$D$27;2;FALSE);"")
za treću grupu postavite formulu
=IF(I28<>"";VLOOKUP(I28;$C$28:$D$40;2;FALSE);"")
i za četvrtu grupu =IF(I41<>"";VLOOKUP(I41;$C$41:$D$53;2;FALSE);"").
I na kraju
ostaje da obojamo naše grupe (po želji) radi lakšeg
uočavanja.
Selektirajte sve ćelije na radnom listu
Sheet1 i zaključajte ih na tabu Protection, u stvari po
defaultu bi trebale biti već zaključane ali ipak za svaki
slučaj ako ste nešto radili sa ovom opcijom. Dakle
Select All => Format Cell => Protection tab => Locked)
Potom selektirajte sve ćelije u kojima upisujete MIn i MAX
pa ih otključajte (isključite opciju Locked). Također
selektirajte nekoliko ćelija u pozadini buttona COPY i
otključajte ih da bi nam se kursor pozicionirao u blizini
buttona nakon svih popunjavanja MIN i MAX. Kliknite na
Review => Protect Sheet (blanko password). Sada ste se
osigurali da nećete ništa obrisati na ovom Sheetu i da će
funkcionirati sve kako treba jer nakon pritiska na tipku
Enter slijedeća selektirana ćelija bit će ona u kojoj treba
upisati MIN ili MAX.
Ovaj
primjer može se jednostavnije riješiti i formulama.
Sheet "baza" ostaje kao u
prethodnom primjeru sa makronaredbom
Sheet "Sheet1" ne sadrži nikakve Makronaredbe već
formule. stupac A i B su linkani (Paste Link) sa sheeta
"baza".
Razlika je da ovdje koristite ili CIJELE ili DECIMALNE
brojeve (jer kombinacija nije baš najsretnije rješenje).
Također trebate voditi računa da brojeve MIN i MAX upisujete
iz raspona dotične grupe.
Prva formula u svakoj grupi vezana je za
red u kojem se nalazi.
Tako za prvu grupu imamo formulu C2:
=VLOOKUP($E$2;$A$2:$B$14;2;TRUE)
Formula ispod koja se kopira do kraja grupe glasi;
C3: =IF($E$2+ROW()-2>$F$2;"";VLOOKUP($E$2+ROW()-2;$A$2:$B$14;2;TRUE))
Isto tako za drugu grupu imamo formulu
C15: =VLOOKUP($E$15;$A$15:$B$27;2;TRUE)
Formula ispod koja se kopira do kraja grupe glasi;
C16: =IF($E$15+ROW()-15>$F$15;"";VLOOKUP($E$15+ROW()-15;$A$15:$B$27;2;TRUE))
|