VBA - Makro beschleunigen bzw. durch Array ersetzen?

[Kuwer]

Hallo Tim,

der Code ersetzt Dein bisheriges Makro. Allerdings waren da noch einige Anpassungen nötig:
- Da Leerzellen nicht wie vorgesehen sortiert werden, werden sie temporär mit einem spezifischen Text gefüllt.
- Der Sortiercode ist nun vollständig und leichter lesbar.
- Da Excel immer abstürzt, wenn man versucht, die Datei zu speichern, wurde zusätzliche Zeile nötig.

Ob dieser Code nun schneller als Deiner ist, weiß ich nicht.

Sub Mitarbeiter_sortieren_Neu()
  Dim Zeile_Position As Long
  Dim Spalte_Position As Long
  
  Application.AddCustomList Array("DAL", "EWF", "X", "x", "TOG", "@@@@@", "MV", "MV1", "MV2", "MV3", "MV4", "MV5", "AP", "AP1", "AP2", "AP3", "AP4", "AP5", "SD", "TD", "TP", "GT", "LG", "Ehu", "EHU", "k", "K", "AO")
  With ThisWorkbook.Sheets("Tabelle1")
    Zeile_Position = 5
    'Zeile_Position = .Shapes(Application.Caller).TopLeftCell.Row 
        'bestimmt die Zeile des Objekts, dass das Makro auslöst 
        
    Spalte_Position = 2
    'Spalte_Position = .Shapes(Application.Caller).TopLeftCell.Column 
        'bestimmt die Spalte des Objekts, dass das Makro auslöst 
    
    With .Cells(Zeile_Position + 2, Spalte_Position).Resize(19, 2)
      If Application.CountBlank(.Columns(2)) Then
        .Columns(2).SpecialCells(xlCellTypeBlanks).Value = "@@@@@"
      End If
      .Sort Key1:=.Cells(1, 2), _
            Order1:=xlAscending, _
            Header:=xlNo, _
            OrderCustom:=Application.CustomListCount + 1
      .Columns(2).Replace "@@@@@", ""
    End With
    'verhindert Excelabsturz beim Versuch, dieses Datei zu speichern, 
    'wenn DeleteCustomList angewendet werden soll 
    .Sort.SortFields.Clear
  End With
  Application.DeleteCustomList Application.CustomListCount
End Sub

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 14 - mit VBAHTML 12.6.0

Gruß Uwe

[EasY]

Hossa Uwe,

das sieht schon sehr gut aus... habe die Berechnungszeiten des Makros mal ausgelesen und dein/euer Makro liegt in der Regel unter der Zeit meines Makros. Das hilft mir auf jeden Fall weiter :).
Da euer Lösungsansatz gänzlich von meiner Erwartung abweicht (positiv), komme ich nun jedoch zu einem neuen Problem:

Lassen sich die drei anderen Makro-Funktionen, die ich ausgeklammert hatte einbauen?

1. Prüfen, ob genügend Leute (Wieviele es sein müssen, steht in ThisWorkbook.ActiveSheet.Cells(Zeile_Position + 1, Spalte_Position + 2).Value) nen X, ein EWF oder ein DAL haben, ansonsten Blankos setzen mit nem X vor denjenigen mit der Funktion TOG?
2. Prüfen, ob mindestens 2 Leute mit TOG verzeichnet sind. Ansonsten Blankos setzen
3. Löschen der TOG-Blankos, wenn nachträglich jemand die Funktion TOG bekommt.


Wenn das zu kompliziert wird, macht es nichts - ich komme schon gut klar damit und sage auf jeden Fall DANKE :)

[snb]

Schau mal:

[EasY]

Hi snb,

leider sortiert er die Liste nicht so, wie ich es gerne hätte.... erst DAL, dann EWF, dann X, dann Leerzeilen und dann den Rest... oder mache ich etwas falsch? Es wird nur der obere Bereich sortiert - die Personen die unten stehen, bleiben auch dort.