[VBA] Array erweitern

[EasY]

Kurzes Update, falls es wen noch interessiert: 

Die Geschwindigkeit war bei einem so kleinen Array (19,4) tatsächlich eher nachrangig. Allerdings war quicksort für meine Belange nicht das richtige, da die Sortierung immer etwas anders war, jedes Mal wenn ich das Makro gestartet habe. 
Mit der Excel-Sortierung habe ich es nun umgesetzt und konnte da als nachrangige Sortierung zusätzlich eine customlist nutzen. Noch stürzt das Makro reproduzierbar nach dem sortieren und anschließendem speichern ab. Google half hier jedoch - man muss die sortfields clearen..... Warum auch immer. 

Gruß

[RPP63]

Moin!
Nimm nicht die Worksheet.Sort-Methode, sondern die Range.Sort-Methode
Letztere kann zwar "nur" 3 Keys, kennt aber auch OrderCustom
(und Du brauchst Dich nicht um SortFields kümmern)

Gruß Ralf

[EasY]

Mh...

dachte, dass ich eine Range sortiere.

Code:

Public Sub Array_ExcelSort(ByRef vArrayName As Variant)
Dim vReturnArray As Variant
Dim lLower As Integer
Dim lUpper As Long
Dim i As Long

Dim lngCLC As Long
Dim lngListExist As Long
Dim lngOC As Long
Dim vListArr As Variant

Dim FirstCell As Range
Dim LastCell As Range
Dim CurrCell As Range
Dim FillRange As Range
   
    lLower = LBound(vArrayName, 1)
    lUpper = UBound(vArrayName, 1)
   
    Set FirstCell = Sheets("Zwischenspeicher").Cells(34, 1)
    Set LastCell = Sheets("Zwischenspeicher").Cells(lUpper + 33, 4)
    Set FillRange = Range(FirstCell, LastCell)
   
    Application.ScreenUpdating = False
    ReDim vReturnArray(lLower To lUpper)
    FillRange.Value = vArrayName
   
vListArr = Sheets("Mitarbeiter").Range("B9:B214")
lngListExist = Application.GetCustomListNum(vListArr)
If lngListExist > 0 Then
    lngOC = lngListExist + 1
Else
    Application.AddCustomList listArray:=vListArr
    lngCLC = Application.CustomListCount
    lngOC = lngCLC + 1
End If
    FillRange.Sort Key1:=FirstCell, Order1:=xlAscending, OrderCustom:=lngOC, MatchCase:=False, Orientation:=xlTopToBottom
    Sheets("Zwischenspeicher").Sort.SortFields.Clear
If lngListExist = 0 Then Application.DeleteCustomList ListNum:=lngCLC
   
    FillRange.Sort Key1:=FirstCell.Offset(0, 3), Order1:=xlAscending, Orientation:=xlTopToBottom
    vArrayName = FillRange
   
    FillRange.Clear
    Application.ScreenUpdating = True

End Sub

So scheint es nun zu funktioneren. Der Code ist aus dem Internet aus zwei Codes zusammenkopiert.

[snb]

Code:

Sub M_snb()
  sn = Sheets("Mitarbeiter").Range("B9:E214")

  Cells(1, 60).Resize(UBound(sn), UBound(sn, 2)) = sn
  Cells(1, 60).currentregion.Sort Cells(1, 60), , Cells(1, 64)
  sn = Cells(1, 60).CurrentRegion
  Cells(1, 60).CurrentRegion.Clear
End Sub