Code schneller machen?

Hallo Forum,
ich habe folgenden Code per Recorder aufgezeichnet, der auch funktioniert-zumindest wenn die parameter stimmen.
Allerdings dauert es sehr lange.
Der Code wird über einen CommandButton ausgeführt.
Kann mir einer den Code umschreiben, dass er schneller ausgeführt wird?


Private Sub Sortieren_Click()
ActiveSheet.Unprotect Password:="passwort"
Dim zeile As Integer ' blendet die Zeilen aus
zeile = 1
For zeile = 17 To 120
If Range("d" & zeile).Value = "" Then
Rows(zeile).Hidden = True
Else
End If
Next zeile
Rows("17:120").Select ' dieser Bereich soll sortiert werden nach Werten in Spalte G Werte 1- _
5, funktioniert nur, wenn Anzahl 1 konstant,
Anzahl 2 konstant, usw., kann aber in der Tabelle variabel sein
ActiveWorkbook.Worksheets("Jahresübersicht").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Jahresübersicht").Sort.SortFields.Add Key:=Range( _
"G17:G120"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Jahresübersicht").Sort
.SetRange Range("A17:UQ120")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Rows("17:122").Select ' ausgeblendete Zeilen wieder einblenden
Selection.EntireRow.Hidden = False
Range("C12").Select
ActiveSheet.Protect Password:="Passwort", DrawingObjects:=False, Contents:=True, Scenarios:= _
_
_
_
_
_
True, AllowFormattingCells:=True, AllowUsingPivotTables:=True
Range("C12").Select
End Sub

Falls jemand Bock darauf hat, vielen Dank im voraus,
Gruß Henno

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Sortieren_Click() Dim Blatt As Worksheet Set Blatt = ActiveWorkbook.Worksheets("Jahresübersicht") Blatt.Unprotect Password:="passwort" Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Blatt.Sort.SortFields.Clear Blatt.Worksheets("Jahresübersicht").Sort.SortFields.Add Key:=Range( _ "G17:G120"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= xlSortNormal With Blatt.Sort .SetRange Blatt.Range("A17:UQ120") .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Range("C12").Select Blatt.Protect Password:="passwort", DrawingObjects:=False, Contents:=True, Scenarios:= _ True, AllowFormattingCells:=True, AllowUsingPivotTables:=True End Sub

Wieso sorry, vielen Dank ;)
Der Code funktioniert, ABER.....
Er löscht ja alle Zeilen, wo keine Inhalte drin sind.....diese hatte ich bei mir ja ausgeblendet und dann sortiert, anschließend wieder eingeblendet, damit die Tabelle nach dem sortieren so ausschaut wie vorher...nur sortiert *gg*
https://www.herber.de/bbs/user/110790.xlsm
Das ist meine Beispieldatei.
Ich habe 5 Abteilungen, und es passiert, das Mitarbeiter a von Abteilung 1 zu Abteilung 3 wechselt usw.
Die maximale Anzahl der Mitarbeiter je Abteilung ist vorgegeben, sie muss aber nicht ausgenutzt werden, daher die Leerzeilen in den jeweiligen Abteilungen.
Die aktuelle Abteilung steht als Zahl in Spalte G, die Idee ist, diese Zahl bei Abteilungwechsel entsprechend abzuändern und neu zu sortieren, die bisherigen Schichten der Mitarbeiter sollen dabei aber nicht "verloren gehen".
Ich hoffe, das ist einigermaßen verständlich ;)

Private Sub Sortieren_Click() Dim Blatt As Worksheet Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set Blatt = ActiveWorkbook.Worksheets("Jahresübersicht") With Blatt .Unprotect Password:="passwort" .Range("D17:D120").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True .Sort.SortFields.Clear .Sort.SortFields.Add Key:=.Range( _ "G17:G120"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With .Sort .SetRange Blatt.Range("A17:UQ120") .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With .Range("D17:D120").EntireRow.Hidden = False .Range("C12").Select Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True .Protect Password:="passwort", DrawingObjects:=False, Contents:=True, Scenarios:= _ True, AllowFormattingCells:=True, AllowUsingPivotTables:=True End With Set Blatt = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

16 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Code schneller machen?

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

16 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread