Možno aj takto, ale pozor, používa sa rovnako veľká oblasť vpravo, kde sa premiestnia zoradené oblasti, a pôvodné stĺpce (už bez oblastí) sa celé zmažú. Vyskúšajte.
Sub ZoradSkupiny()
Dim Col As Collection, Riadkov As Long, Skupin As Long, i As Long, c, Datum As Date, Dat(), Z As Boolean, OldRng As String
Set Col = New Collection
With ThisWorkbook.ActiveSheet
Riadkov = .Cells(Rows.Count, 2).End(xlUp).Row + 2
Skupin = Riadkov \ 9
If Riadkov / 9 <> Skupin Then MsgBox "Oblasti niesú rovnomerné! Koniec.": Exit Sub
ReDim Dat(1 To Riadkov, 1 To 1)
Dat = .Cells(1, 12).Resize(Riadkov).Value
For i = 1 To Skupin
Datum = Dat((i - 1) * 9 + 3, 1)
Z = False
If Col.Count > 0 Then
For Each c In Col
If c(0) > Datum Then Col.Add Array(Datum, i), Before:=CStr(c(1)): Z = True: Exit For
Next c
If Z = False Then Col.Add Array(Datum, i), CStr(i)
Else
Col.Add Array(Datum, i), CStr(i)
End If
Next i
With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual: End With
OldRng = Selection.Address
.Cells(1, 1).Resize(, 13).Copy
.Cells(1, 14).Resize(, 13).PasteSpecial Paste:=xlPasteColumnWidths
Riadkov = 0
For Each c In Col
.Cells((c(1) - 1) * 9 + 1, 1).Resize(9, 13).Cut
.Cells(Riadkov * 9 + 1, 14).Resize(9, 13).Insert Shift:=xlDown
Riadkov = Riadkov + 1
Next c
.Columns(1).Resize(, 13).EntireColumn.Delete
With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic: End With
.Range(OldRng).Select
End With
Set Col = Nothing
End Sub
Sub ZoradSkupiny()
Dim Col As Collection, Riadkov As Long, Skupin As Long, i As Long, c, Datum As Date, Dat(), Z As Boolean, OldRng As String
Set Col = New Collection
With ThisWorkbook.ActiveSheet
Riadkov = .Cells(Rows.Count, 2).End(xlUp).Row + 2
Skupin = Riadkov \ 9
If Riadkov / 9 <> Skupin Then MsgBox "Oblasti niesú rovnomerné! Koniec.": Exit Sub
ReDim Dat(1 To Riadkov, 1 To 1)
Dat = .Cells(1, 12).Resize(Riadkov).Value
For i = 1 To Skupin
Datum = Dat((i - 1) * 9 + 3, 1)
Z = False
If Col.Count > 0 Then
For Each c In Col
If c(0) > Datum Then Col.Add Array(Datum, i), Before:=CStr(c(1)): Z = True: Exit For
Next c
If Z = False Then Col.Add Array(Datum, i), CStr(i)
Else
Col.Add Array(Datum, i), CStr(i)
End If
Next i
With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual: End With
OldRng = Selection.Address
.Cells(1, 1).Resize(, 13).Copy
.Cells(1, 14).Resize(, 13).PasteSpecial Paste:=xlPasteColumnWidths
Riadkov = 0
For Each c In Col
.Cells((c(1) - 1) * 9 + 1, 1).Resize(9, 13).Cut
.Cells(Riadkov * 9 + 1, 14).Resize(9, 13).Insert Shift:=xlDown
Riadkov = Riadkov + 1
Next c
.Columns(1).Resize(, 13).EntireColumn.Delete
With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic: End With
.Range(OldRng).Select
End With
Set Col = Nothing
End Sub
Příloha: 
41696_zoradenie-oblasti.zip (25kB, staženo 25x)
citovat41696_zoradenie-oblasti.zip (25kB, staženo 25x)
RSS nejnovější články