Option Explicit
Dim oSlist1 As Object, oSlist2 As Object
Dim oWsh1 As Worksheet, oWsh2 As Worksheet
Sub SortIt()
BeforeSort
DoSort
AfterSort
Set oSlist1 = Nothing
Set oSlist2 = Nothing
End Sub
Sub AfterSort()
Dim rngRel As Range, c As Range
Dim rngFound As Range
Dim arrKalender()
Set oWsh1 = ThisWorkbook.Sheets(1)
Set oWsh2 = ThisWorkbook.Sheets(2)
Application.ScreenUpdating = False
With oWsh1
.Activate
Set rngRel = .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))
If rngRel.Rows.Count = Rows.Count - 1 Then Exit Sub
For Each c In rngRel
.ClearArrows
c.ShowDependents
Set rngFound = c.NavigateArrow(False, 1, 1)
rngFound.Offset(, 3).Value = _
oSlist1.getByIndex(oSlist1.IndexOfKey(rngFound.Value))
arrKalender = oSlist2.getByIndex(oSlist2.IndexOfKey(rngFound.Value))
Set c = rngFound.Offset(, 5).Resize(UBound(arrKalender, 1), UBound(arrKalender, 2))
c.Value = arrKalender
oWsh1.Activate
.ClearArrows
Next c
End With
Application.ScreenUpdating = True
Set oWsh1 = Nothing
Set oWsh2 = Nothing
End Sub
Sub DoSort()
Set oWsh1 = ThisWorkbook.Sheets(1)
Dim rngSort As Range
Dim strSort As String
Dim strKey1 As String, strKey2 As String
With oWsh1
Set rngSort = Range("A1").CurrentRegion
strSort = rngSort.Address
strKey1 = rngSort.Columns(2).Address
strKey2 = rngSort.Columns(3).Address
With .Sort
With .SortFields
.Clear
.Add Key:=Range(strKey1) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add Key:=Range(strKey2) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With
.SetRange Range(strSort)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
Set oWsh1 = Nothing
End Sub
Sub BeforeSort()
Dim rngRel As Range, c As Range
Dim rngFound As Range
Dim arrKalender() As Variant
Set oWsh1 = ThisWorkbook.Sheets(1)
Set oWsh2 = ThisWorkbook.Sheets(2)
Set oSlist1 = CreateObject("System.Collections.Sortedlist")
Set oSlist2 = CreateObject("System.Collections.Sortedlist")
Application.ScreenUpdating = False
With oWsh1
.Activate
Set rngRel = .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))
If rngRel.Rows.Count = Rows.Count - 1 Then Exit Sub
For Each c In rngRel
.ClearArrows
c.ShowDependents
Set rngFound = c.NavigateArrow(False, 1, 1)
oSlist1.Add c.Value, rngFound.Offset(, 3).Value
arrKalender = Range(rngFound.Offset(, 5), rngFound.Offset(, 16))
oSlist2.Add c.Value, arrKalender
oWsh1.Activate
.ClearArrows
Next c
End With
Application.ScreenUpdating = True
Set oWsh1 = Nothing
Set oWsh2 = Nothing
End Sub