Sub slaganjeVrsta()
'aktivni List
Dim aktivniList As String
aktivniList = ActiveSheet.Name
Range("A1").Select
'odredivanje prve kolone i zadnje kolone
Dim prvaKolona As Long
Dim zadnjaKolona As Long
Range("B1").Select
prvaKolona = 2
zadnjaKolona = traziZadnjuKolonu(aktivniList)
Dim arrVrsta() As Variant
Dim i As Long
ReDim Preserve arrVrsta(i)
arrVrsta(i) = Cells(2, 2)
'stvaranje matrice bez ponavljanja
For c = prvaKolona To zadnjaKolona
If arrVrsta(i) <> Cells(2, c) Then
i = i + 1
ReDim Preserve arrVrsta(i)
arrVrsta(i) = Cells(2, c)
End If
Next c
'matrica ima vrijednost arrVrsta(0)=voce i arrVrsta(1)=povrce
i = 0
For c = 2 To zadnjaKolona
'u svakom stupcu trazimo max broj redova
If zadnjiSortRed < traziZadnjiRed(aktivniList, c) Then
zadnjiSortRed = traziZadnjiRed(aktivniList, c)
End If
If i < Ubound(arrVrsta) Then 'ako petlja nije dosla do zadnje vrijednosti matrice
If Cells(2, c) = arrVrsta(i) Then 'ako je celija vrijednosti matrice npr voce=voce
prvaSortKolona = c 'uzimamo broj kolone za pocetak ranga
i = i + 1
Else 'ako celija nema vrijednost matrice npr voce<>povrce
zadnjaSortKolona = c 'uzimamo broj kolone za kraj ranga
If Cells(2, c + 1) = arrVrsta(i) Then
Range(Cells(1, prvaSortKolona), Cells(zadnjiSortRed, zadnjaSortKolona)).Select
'sortiranje
Range(Cells(1, prvaSortKolona), Cells(zadnjiSortRed, zadnjaSortKolona)).Sort _
Key1:=Range(Cells(1, 2), Cells(1, zadnjaSortKolona)), _
Order1:=xlAscending, _
Orientation:=xlLeftToRight
prvaSortKolona = c
End If
End If
Else
If c = zadnjaKolona Then
Range(Cells(1, prvaSortKolona), Cells(zadnjiSortRed, zadnjaKolona)).Select
'sortiranje
Range(Cells(1, prvaSortKolona), Cells(zadnjiSortRed, zadnjaKolona)).Sort _
Key1:=Range(Cells(1, 2), Cells(1, zadnjaKolona)), _
Order1:=xlAscending, _
Orientation:=xlLeftToRight
End If
End If
Next c
End Sub
Function traziZadnjiRed(ImeSita As String, kolona)
Dim Zadnji As Long
Dim ws As Worksheet
Set ws = Sheets(ImeSita)
With ws
Zadnji = .Cells(.Rows.Count, kolona).End(xlUp).Row
End With
traziZadnjiRed = Zadnji
End Function
Function traziZadnjuKolonu(ImeSita As String)
Dim Zadnji As Long
Dim ws As Worksheet
Set ws = Sheets(ImeSita)
With ws
Zadnji = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
traziZadnjuKolonu = Zadnji
End Function