Live-Forum - Die aktuellen Beiträge
Datum
Titel
26.04.2024 21:51:33
Idee für Grafik
26.04.2024 21:29:07
PQ zufällige Reihenfolge
26.04.2024 17:18:47
Große Datenmenge in komplexes Diagramm verpacken
26.04.2024 16:22:47
Aktualisierung Verknüpfung bei geschlossener Quelldatei
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1708to1712
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1708to1712
1708to1712
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Code läuft zu lange

Code läuft zu lange
18.08.2019 08:36:56
Holly
Guten Morgen,
ich habe einen Code der auch läuft nur dauert es sehr lange ca. 20min.
Da ich nicht viel Ahnung habe wäre es schön wenn eine mal über den Code schuen könnte und mir sagt wie man ihn Optimiert. Vieles wiederholt sich, da ich aber nicht weiß wie man es kürzt habe ich es immer wieder Kopiert und eingefügt.
Ich hoffe es ist verständlich genug.
Vielen dank schon mal. 
Private Sub CommandButton3_Click()
Application.ScreenUpdating = False
Dim FrühA As String
Dim FrühB As String
Dim FrühC As String
Dim FrühD As String
Dim FrühE As String
Dim FrühF As String
Dim FrühG As String
Dim FrühH As String
Dim FrühI As String
Dim FrühJ As String
Dim SpätA As String
Dim SpätB As String
Dim SpätC As String
Dim SpätD As String
Dim SpätE As String
Dim SpätF As String
Dim SpätG As String
Dim SpätH As String
Dim SpätI As String
Dim SpätJ As String
Dim DoegoA As String
Dim DoegoB As String
Dim DoegoC As String
Dim DoegoD As String
Dim DoegoE As String
Dim DoegoF As String
Dim DoegoG As String
Dim DoegoH As String
Dim DoegoI As String
Dim DoegoJ As String
Dim TL As String
Dim Frei1 As String
Dim Frei2 As String
Dim Frei3 As String
Dim Früh As String
Dim Spät As String
Dim Doego As String
Application.ScreenUpdating = False
Sheets("Gruppen").Visible = True
Sheets("Gruppen").Select
Range("B:E,H:K,N:Q,T:W").Select
Range("T1").Activate
Selection.ClearContents
ActiveWindow.SmallScroll Down:=-12
Range("B2").Select
FrühA = Worksheets("Stammdaten").Cells(2, 5).Value 'Stammdaten("E2")
FrühB = Worksheets("Stammdaten").Cells(3, 5).Value 'Stammdaten("E3")
FrühC = Worksheets("Stammdaten").Cells(4, 5).Value 'Stammdaten("E4")
FrühD = Worksheets("Stammdaten").Cells(5, 5).Value 'Stammdaten("E5")
FrühE = Worksheets("Stammdaten").Cells(6, 5).Value 'Stammdaten("E6")
FrühF = Worksheets("Stammdaten").Cells(7, 5).Value 'Stammdaten("E7")
FrühG = Worksheets("Stammdaten").Cells(8, 5).Value 'Stammdaten("E8")
FrühH = Worksheets("Stammdaten").Cells(9, 5).Value 'Stammdaten("E9")
FrühI = Worksheets("Stammdaten").Cells(10, 5).Value 'Stammdaten("E10")
FrühJ = Worksheets("Stammdaten").Cells(11, 5).Value 'Stammdaten("E11")
SpätA = Worksheets("Stammdaten").Cells(12, 5).Value 'Stammdaten("E12")
SpätB = Worksheets("Stammdaten").Cells(13, 5).Value 'Stammdaten("E13")
SpätC = Worksheets("Stammdaten").Cells(14, 5).Value 'Stammdaten("E14")
SpätD = Worksheets("Stammdaten").Cells(15, 5).Value 'Stammdaten("E15")
SpätE = Worksheets("Stammdaten").Cells(16, 5).Value 'Stammdaten("E16")
SpätF = Worksheets("Stammdaten").Cells(17, 5).Value 'Stammdaten("E17")
SpätG = Worksheets("Stammdaten").Cells(18, 5).Value 'Stammdaten("E18")
SpätH = Worksheets("Stammdaten").Cells(19, 5).Value 'Stammdaten("E19")
SpätI = Worksheets("Stammdaten").Cells(20, 5).Value 'Stammdaten("E20")
SpätJ = Worksheets("Stammdaten").Cells(21, 5).Value 'Stammdaten("E21")
DoegoA = Worksheets("Stammdaten").Cells(22, 5).Value 'Stammdaten("E22")
DoegoB = Worksheets("Stammdaten").Cells(23, 5).Value 'Stammdaten("E23")
DoegoC = Worksheets("Stammdaten").Cells(24, 5).Value 'Stammdaten("E24")
DoegoD = Worksheets("Stammdaten").Cells(25, 5).Value 'Stammdaten("E25")
DoegoE = Worksheets("Stammdaten").Cells(26, 5).Value 'Stammdaten("E26")
DoegoF = Worksheets("Stammdaten").Cells(27, 5).Value 'Stammdaten("E27")
DoegoG = Worksheets("Stammdaten").Cells(28, 5).Value 'Stammdaten("E28")
DoegoH = Worksheets("Stammdaten").Cells(29, 5).Value 'Stammdaten("E29")
DoegoI = Worksheets("Stammdaten").Cells(30, 5).Value 'Stammdaten("E30")
DoegoJ = Worksheets("Stammdaten").Cells(31, 5).Value 'Stammdaten("E31")
TL = Worksheets("Stammdaten").Cells(32, 5).Value 'Stammdaten("E32")
Frei1 = Worksheets("Stammdaten").Cells(33, 5).Value 'Stammdaten("E33")
Frei2 = Worksheets("Stammdaten").Cells(34, 5).Value 'Stammdaten("E34")
Frei3 = Worksheets("Stammdaten").Cells(35, 5).Value 'Stammdaten("E35")
Früh = Worksheets("Stammdaten").Cells(36, 5).Value 'Stammdaten("E36")
Spät = Worksheets("Stammdaten").Cells(37, 5).Value 'Stammdaten("E37")
Doego = Worksheets("Stammdaten").Cells(38, 5).Value 'Stammdaten("E38")
'FrühA = Worksheets("Stammdaten").Cells(2, 5).Value 'Stammdaten("E2")
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=FrühA 'Stammdaten E2
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=FrühB 'Stammdaten E3
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("B13").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=FrühC 'Stammdaten E4
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("B24").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=FrühD 'Stammdaten E5
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("B35").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=FrühE 'Stammdaten E6
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("B46").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=FrühF 'Stammdaten E7
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("H2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=FrühG 'Stammdaten E8
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("H13").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=FrühH 'Stammdaten E9
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("H24").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=FrühI 'Stammdaten E10
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("H35").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=FrühJ 'Stammdaten E11
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("H46").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=SpätA 'Stammdaten E12
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("N2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=SpätB
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("N13").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=SpätC 'Stammdaten E13
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("N24").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=SpätD 'Stammdaten E14
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("N35").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=SpätE
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("N46").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=SpätF 'Stammdaten E15
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("T2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=SpätG 'Stammdaten E16
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("T13").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=SpätH 'Stammdaten E17
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("T24").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=SpätI 'Stammdaten E18
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("T35").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=SpätJ 'Stammdaten E19
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("T46").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=DoegoA 'Stammdaten E22
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("B57").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=DoegoB 'Stammdaten E23
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("B68").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=DoegoC 'Stammdaten E24
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("B79").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=DoegoD 'Stammdaten E25
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("B90").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=DoegoE 'Stammdaten E26
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("B101").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=DoegoF 'Stammdaten E27
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("H57").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=DoegoG 'Stammdaten E28
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("H68").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=DoegoH 'Stammdaten E29
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("H79").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=DoegoI 'Stammdaten E30
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("H90").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=DoegoJ 'Stammdaten E31
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("H101").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B2").Select
Sheets("Mitarbeiter").Select
Application.CutCopyMode = False
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1
'drucken
Sheets("Gruppen").Activate
ActiveWindow.SmallScroll Down:=-5
'Set ActiveSheet.VPageBreaks(1).Location = Range("M1")
'Set ActiveSheet.HPageBreaks(1).Location = Range("A34")
ActiveWindow.SmallScroll Down:=22
'Set ActiveSheet.HPageBreaks(1).Location = Range("A56")
ActiveWindow.SmallScroll Down:=15
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = "© 2019 by Holger Schremb"
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(3.93700787401575E-02)
.RightMargin = Application.InchesToPoints(3.93700787401575E-02)
.TopMargin = Application.InchesToPoints(3.93700787401575E-02)
.BottomMargin = Application.InchesToPoints(3.93700787401575E-02)
.HeaderMargin = Application.InchesToPoints(0.31496062992126)
.FooterMargin = Application.InchesToPoints(0.31496062992126)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 92
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
Sheets("Mitarbeiter").Select
Selection.Autofilter
Sheets("Gruppen").Visible = False
Unload Me
Application.ScreenUpdating = True
UserForm1.Show
End Sub

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Code läuft zu lange
18.08.2019 09:46:36
Regina
Moin,
ohne Deine Datei zu kennen, könnte man den folgenden Block kürzen.
Deine Version: 
  Sheets("Mitarbeiter").Select
ActiveSheet.Range("$E$1:$E$1001").Autofilter Field:=1, Criteria1:=FrühA 'Stammdaten E2
Range("B2:E1002").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Gruppen").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Gekürzt: 
Sheets("Mitarbeiter").Range("$E$1:$E$1001").AutoFilter Field:=1, Criteria1:=FrühA
Sheets("Mitarbeiter").Range("B2:E1002").Copy Sheets("Gruppen").Range("B2")
In aller Regel kann man auf Selects verzichten, das dürfte die Geschwindigkeit schon mal optimieren.
Für weiter Optimierungen müsste man die Daten sehen, evtl. kann man auch etwas am Aufbau ändern, um die Performance zu verbessern.
Gruß
Regina
Anzeige
AW: Code läuft zu lange
18.08.2019 11:28:29
Werner
Hallo,
ein paar Anmerkungen:
du hast in deinem Code folgende Variablen deklariert und hast ihnen auch Werte zugewiesen:
Frei1, Frei2, Frei3, Früh, Spät, Doego
Verwendet wird aber im Code keine dieser Variablen.
Ich hab die jetzt einfach mal raus geschmissen.
Teste mal: 
Private Sub CommandButton3_Click()
Dim Früh As Variant, Spät As Variant, Doego As Variant, Frei As Variant
Dim i As Long, z As Long, loLetzte As Long
Application.ScreenUpdating = False
With Worksheets("Gruppen")
.Range("B:E,H:K,N:Q,T:W").ClearContents
End With
With Worksheets("Stammdaten")
Früh = WorksheetFunction.Transpose(.Range("E2:E11"))
Spät = WorksheetFunction.Transpose(.Range("E12:E21"))
Doego = WorksheetFunction.Transpose(.Range("E22:E31"))
End With
With Sheets("Mitarbeiter")
loLetzte = .Cells(.Rows.Count, 2).End(xlUp).Row
z = 2
For i = 1 To 5
.Range("$B$1:$E$" & loLetzte).AutoFilter Field:=4, Criteria1:=Früh(i)
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Copy
Worksheets("Gruppen").Range("B" & z).PasteSpecial Paste:=xlPasteValues
z = z + 11
End With
Next i
z = 2
For i = 6 To 10
.Range("$B$1:$E$" & loLetzte).AutoFilter Field:=4, Criteria1:=Früh(i)
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Copy
Worksheets("Gruppen").Range("H" & z).PasteSpecial Paste:=xlPasteValues
z = z + 11
End With
Next i
z = 2
For i = 1 To 5
.Range("$B$1:$E$" & loLetzte).AutoFilter Field:=4, Criteria1:=Spät(i)
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Copy
Worksheets("Gruppen").Range("N" & z).PasteSpecial Paste:=xlPasteValues
z = z + 11
End With
Next i
z = 2
For i = 6 To 10
.Range("$B$1:$E$" & loLetzte).AutoFilter Field:=4, Criteria1:=Spät(i)
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Copy
Worksheets("Gruppen").Range("T" & z).PasteSpecial Paste:=xlPasteValues
z = z + 11
End With
Next i
z = 57
For i = 1 To 5
.Range("$B$1:$E$" & loLetzte).AutoFilter Field:=4, Criteria1:=Doego(i)
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Copy
Worksheets("Gruppen").Range("B" & z).PasteSpecial Paste:=xlPasteValues
z = z + 11
End With
Next i
z = 57
For i = 6 To 10
.Range("$B$1:$E$" & loLetzte).AutoFilter Field:=4, Criteria1:=Doego(i)
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Copy
Worksheets("Gruppen").Range("H" & z).PasteSpecial Paste:=xlPasteValues
z = z + 11
End With
Next i
Application.CutCopyMode = False
If .AutoFilterMode Then .ShowAllData
End With
'     'drucken
With Sheets("Gruppen")
'Set ActiveSheet.VPageBreaks(1).Location = Range("M1")
'Set ActiveSheet.HPageBreaks(1).Location = Range("A34")
'Set ActiveSheet.HPageBreaks(1).Location = Range("A56")
Application.PrintCommunication = False
With .PageSetup
.PrintArea = ""
.PrintTitleRows = ""
.PrintTitleColumns = ""
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = "© 2019 by Holger Schremb"
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(3.93700787401575E-02)
.RightMargin = Application.InchesToPoints(3.93700787401575E-02)
.TopMargin = Application.InchesToPoints(3.93700787401575E-02)
.BottomMargin = Application.InchesToPoints(3.93700787401575E-02)
.HeaderMargin = Application.InchesToPoints(0.31496062992126)
.FooterMargin = Application.InchesToPoints(0.31496062992126)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 92
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
End With
'Unload Me
'UserForm1.Show
End Sub
Gruß Werner
Anzeige
AW: Code läuft zu lange
18.08.2019 12:03:25
Daniel
Hi
als erstes mal solltest du dir das Select, Selection und Activate abgewöhnen.
der Recorder zeichnet das zwar so auf, weil er muss, aber im Code benötigt wird es nicht.
Weiteres dazu hier: https://www.online-excel.de/excel/singsel_vba.php?f=78
der Code ließe sich schon mal wesentlich kürzen und komplett in einer Schleife darstellen, wenn du beispielsweise auch die Zielzelle für jede Gruppe in den Stammdaten hinterlegst.
Beispiel:
FrühA wird in das Blatt Gruppen!B2 kopiert, also tragst du in den Stammdaten F2 den Wert "B2" ein
FrühB wird in das Blatt Gruppen!B13 kopiert, also trägst du in den Stammdaten F3 den Wert "B13" ein
...
DoegoJ wird in das Blatt Gruppen!H101 kopiert, also trägst du in den Stammdaten F31 den Wert "H101" ein
desweitern würde ich die Mitarbeiterliste nach der Spalte E sortieren.
dann stehen die Zeilen, die du zu einer Gruppe kopieren musst, direkt untereinander.
dann brauchst du nicht den Autofilter, sondern kannst die Zellen per .Find ermitteln und als Block kopieren. Das sollte schneller sein als über den Autofilter.
auch die Druckeinstellung würde ich nicht im Code machen, sondern das Blatt gleich direkt passend einstellen.
Druckeinstellungen sollte man nur per Code ändern, wenn bestimmte Einstellungen in abhängigkeit von berechneten Werten geändert werden müssen.
Sind die Einstellungen immer gleich, braucht man das nicht im Code tun (es sei denn, man vermutet dass ein Andender die Einstllungen verbotenderweise ändern wird, aber das ist bei dir ja durch das ausblenden des Blattes ausgeschlossen.
hier dann der Code, ich habe mal alles rausgelöscht, was meiner Ansicht nach nicht benötigt wird, auch die nicht verendeten Variablen.
Private Sub CommandButton3_Click()
Application.ScreenUpdating = False
Dim StammDaten
Dim z As Long
Dim Zelle1 As Range, Zelle2 As Range
Application.ScreenUpdating = False
Sheets("Gruppen").Visible = True
Sheets("Gruppen").Range("B:E,H:K,N:Q,T:W").ClearContents
StammDaten = Worksheets("Stammdaten").Range("E2:F31").Value
With Sheets("Mitarbeiter").UsedRange
.Sort key1:=.Cells(1, 5), order1:=xlAscending, Header:=xlYes
End With
With Sheets("Mitarbeiter")
For z = 1 To UBound(StammDaten)
Set Zelle1 = .Columns(5).Find(what:=StammDaten(z, 1), _
lookat:=xlWhole, Searchdirection:=xlNext)
Set Zelle2 = .Columns(5).Find(what:=StammDaten(z, 1), _
lookat:=xlWhole, Searchdirection:=xlPrevious)
If Not Zelle1 Is Nothing Then
Range(Zelle1.Offset(0, -3), Zelle2).Copy
Sheets("Gruppen").Range(StammDaten(z, 2)).PasteSpecial xlPasteValues
End If
Next
End With
'drucken
Sheets("Gruppen").PrintOut , copies:=1
Sheets("Gruppen").Visible = False
Unload Me
Application.ScreenUpdating = True
UserForm1.Show
End Sub
Ist jetzt natürlich mangels beispieldatei nicht getestet und die Optimierungen beziehen sich nur darauf, was man aus dem Code erkennen kann.
Du solltest mal die Beispieldatei hochladen.
Ich habe das gefühl, dass man das Ausfüllen des Blattes Gruppen auch per Formel erledigen kann, so dass du dann gar keinen Code mehr dafür benötigst sondern das Blatt direkt drucken kannst.
Gruß Daniel
Anzeige
AW: Code läuft zu lange
19.08.2019 00:14:02
Holger
Vielen Dank an Regina, Werner und Daniel
ich habe durch eure Beiträge viel gelernt.
Es läuft jetzt auch besser.
AW: Code läuft zu lange
19.08.2019 00:21:44
Werner
Hallo Holger,
Es läuft jetzt auch besser.
Bedeutet was im Vergleich zu vorher?
Gruß Werner

Links zu Excel-Dialogen

CommandButton UserForm

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige