Live-Forum - Die aktuellen Beiträge
Datum
Titel
19.04.2024 08:41:23
Zwei Makros in ein Arbeitsblatt - zweite wird nicht ausführt
18.04.2024 21:09:11
4 Spalten aus smarter Tabelle in andere smarte Tab. kopieren
18.04.2024 20:45:35
Worksheet_Activate für alle Sheets
18.04.2024 19:30:20
VBA - Tabelle mit Mannschaftsergebnissen sortieren
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1336to1340
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
1336to1340
1336to1340
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Schleife dauert ewig

Schleife dauert ewig
05.11.2013 14:44:29
Albert
Hallo zusammen,
ich hab da eine Schleife zusammengebastelt, die zwar läuft aber für 25 Zeilen gut und gerne eine Minute braucht.
In einem späteren Dasein würden dann rund 2200 Zeilen durchlaufen werden. Also nicht prickelnd.
Das Makro macht eigentlich nichts schwieriges. In Abhängigkeit vom Zellwert wird aus dem Sheet "Hilfe" ein Schichtzyklus in den "Regelplan" kopiert.
Sub Schleife()
'Regelschichtplan
'Regelschichtplan auswählen und einfügen
Sheets("Regelplan").Select
For Each Zelle In Range(Cells(6, 2), Cells(Range("B200").End(xlUp).Row, 1))
If Zelle.Value = "A" Then
'A-Schichtzyklus
'Sheet auswählen aus Hilfssheet holen
Sheets("Hilfe").Select
'Zyklus der A-Schicht markieren/kopieren
Range("C4:AK4").Select
Selection.Copy
Sheets("Regelplan").Select
'Zelle für Schichtbeginn markieren
Cells(Selection.Row + 1, Selection.Column).Select
ActiveSheet.Paste
End If
Next Zelle
Application.CutCopyMode = False
For Each Zelle In Range(Cells(6, 2), Cells(Range("B200").End(xlUp).Row, 1))
If Zelle.Value = "B" Then
'B-Schichtzyklus
'Sheet auswählen aus Hilfssheet holen
Sheets("Hilfe").Select
'Zyklus der A-Schicht markieren/kopieren
Range("C5:AK5").Select
Selection.Copy
Sheets("Regelplan").Select
'Zelle für Schichtbeginn markieren
Cells(Selection.Row + 1, Selection.Column).Select
ActiveSheet.Paste
End If
Next Zelle
Application.CutCopyMode = False
For Each Zelle In Range(Cells(6, 2), Cells(Range("B200").End(xlUp).Row, 1))
If Zelle.Value = "C" Then
'C-Schichtzyklus
'Sheet auswählen aus Hilfssheet holen
Sheets("Hilfe").Select
'Zyklus der A-Schicht markieren/kopieren
Range("C6:AK6").Select
Selection.Copy
Sheets("Regelplan").Select
'Zelle für Schichtbeginn markieren
Cells(Selection.Row + 1, Selection.Column).Select
ActiveSheet.Paste
End If
Next Zelle
Application.CutCopyMode = False
For Each Zelle In Range(Cells(6, 2), Cells(Range("B200").End(xlUp).Row, 1))
If Zelle.Value = "D" Then
'D-Schichtzyklus
'Sheet auswählen aus Hilfssheet holen
Sheets("Hilfe").Select
'Zyklus der A-Schicht markieren/kopieren
Range("C7:AK7").Select
Selection.Copy
Sheets("Regelplan").Select
'Zelle für Schichtbeginn markieren
Cells(Selection.Row + 1, Selection.Column).Select
ActiveSheet.Paste
End If
Next Zelle
Application.CutCopyMode = False
For Each Zelle In Range(Cells(6, 2), Cells(Range("B200").End(xlUp).Row, 1))
If Zelle.Value = "E" Then
'E-Schichtzyklus
'Sheet auswählen aus Hilfssheet holen
Sheets("Hilfe").Select
'Zyklus der A-Schicht markieren/kopieren
Range("C8:AK8").Select
Selection.Copy
Sheets("Regelplan").Select
'Zelle für Schichtbeginn markieren
Cells(Selection.Row + 1, Selection.Column).Select
ActiveSheet.Paste
End If
Next Zelle
Application.CutCopyMode = False
End Sub
Ich wär euch um Hilfe und Unterstützung echt dankbar.
Gruß
A.

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

Betreff
Datum
Anwender
Anzeige
AW: Schleife dauert ewig
05.11.2013 14:51:18
Hajo_Zi
verzichte auf Select.
Select, Activate usw. ist in VBA zu 99,9% nicht notwendig.
Der Cursor ist kein Hund der überall rumgeführt werden muss.
Hinweise zu select usw. Hajo-Excel.de
Hinweise zu select usw. Online-Excel.de
                Dim LoZeile As Integer
Dim InSpalte As Integer
LoZeile = 12
InSpalte = 2
Sheets("Hilfe").Range("C4:AK4").Copy Sheets("Regelplan").Cells(inzeile,  _
InSpalte)
LoZeile = LoZeile + 1

Anzeige
?
05.11.2013 15:06:37
Albert
Hallo Hajo,
danke für deinen Tipp mit den select's.
Die Schleifen laufen zwar, aber es dauert eben.
Ich hab die Datei mal angehängt. Es ist nämlich ausschlaggebend, wann die erste Schicht mit Frühschicht beginnt. Also nicht pauschal in Spalte B beginnen.
Danke und Gruß
A.

Anhang: Wo? owT
05.11.2013 15:07:56
Rudi

AW: Teufel noch eins...
05.11.2013 18:00:10
fcs
Hallo Albert,
hier eine Textdatei mit deinem Makro zur Userform-Schaltfläche in optimierter Form.
https://www.herber.de/bbs/user/87952.txt
mfg
Franz

Anzeige
AW: Schleife dauert ewig
05.11.2013 15:07:06
Rudi
Hallo,
1. Select/ Activate raus
2. durläufst du die Schleife 5 mal.
Als Beispiel: 
Sub Schleife()
'Regelschichtplan
Dim iOffset As Integer, Zelle As Range, lRow As Long, lCol As Long
lCol = 1  'Einfügespalte
With Sheets("Regelplan")
iOffset = ActiveCell.Row
For Each Zelle In .Range(.Cells(6, 2), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 1))
Select Case Zelle.Value
Case "A": lRow = 4
Case "B": lRow = 5
Case "C": lRow = 6
Case "D": lRow = 7
Case "E": lRow = 8
End Select
iOffset = iOffset + 1
With Sheets("Hilfe")
.Range(.Cells(lRow, 3), .Cells(lRow, 37)).Copy
End With
.Paste .Cells(lRow, 1)
Next Zelle
End With
Application.CutCopyMode = False
End Sub

Gruß
Rudi

Anzeige
AW: Schleife dauert ewig
05.11.2013 21:03:12
Albert
Servus Rudi,
dein Code bleibt beim Sheet("Hilfe") mit objektbezogenem Fehler stehen.
Keine Ahnung, auch nach eingen Versuchen, keine Chance an was es liegt
Gruß
A.

Dann gibt's das wohl nicht! ;-) Gruß owT
05.11.2013 22:53:19
Luc:-?
:-?

@Hajo & euch alle.... Fehler gefunden
06.11.2013 08:50:41
Albert
Guten Morgen zusammen,
hab den Fehler gefunden.
Man sollte hald den Code in ein Modul kopieren und nicht in ein Tabellensheet mit CommandButton.
Mei bin ich doof...
Danke für eure Hilfe
Gruß
A.

AW: Schleife dauert ewig
06.11.2013 13:07:41
Rudi
Hallo,
hier der komplette Code für die Schaltfläche: 
Private Sub Erstellen_Regelplan_Click()
Dim intR As Integer
Dim rngZelle As Range
Dim rngFirstDay As Range
Dim wksRegel As Worksheet, wksKontakt As Worksheet, wksHilfe As Worksheet
Dim lCol As Long, iOffset As Integer, lRow As Long
Set wksRegel = Sheets("Regelschichtplan")
Set wksKontakt = Sheets("Kontaktdaten")
Set wksHilfe = Sheets("Hilfe")
Application.ScreenUpdating = False
'intR = MsgBox("Sind sie sicher?", vbYesNo, "Neuer Regelschichtplan")
'If intR = 6 Then
'Jahreszahl überprüfen, ob sie vierstellig ist
If Len(TextBox1.Text)  31 Then
MsgBox "Der eingegebene Wert liegt höher als 31 Monatstage"
Exit Sub
End If
'Ersten Tag des Jahres einfügen
With wksRegel
.Range("C4:OH5").ClearContents
.Range(.Cells(6, 1), .Cells(Rows.Count, 1).End(xlUp)).EntireRow.ClearContents
.Range("C4").Value = CDate("01.01." & TextBox1.Value)
With .Range("D4:OH4")
.FormulaR1C1 = "=RC[-1]+1"
.Value = .Value
End With
With .Range("C5:OH5")
.FormulaR1C1 = "=text(R[-1]C,""TTT"")"
.Value = .Value
End With
With .Range("C4:OH5")
'Formatierung einbringen
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
'Automatische Spaltenbreite anpassen
.Columns("E:OH").EntireColumn.AutoFit
End With
End With
'Kontakte aus den Kontaktdaten in den Regelschichtplan laden
'Sheet anwählen
With wksKontakt
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("C4"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=Range("A4"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With .Sort
.SetRange Range("A3:E" & Range("E200").End(xlUp).Row)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Namen kopieren        'Namen in den Regelschichtplan einfügen
.Range(.Cells(4, 1), .Cells(.Rows.Count, 1).End(xlUp)).Copy wksRegel.Range("A6")
'Regelschicht kopieren        'Namen in den Regelschichtplan einfügen
.Range(.Cells(4, 3), .Cells(.Rows.Count, 3).End(xlUp)).Copy wksRegel.Range("B6")
End With
'Ersten Schichttag definieren
With wksRegel
Set rngFirstDay = .Cells(4, TextBox2 + 2)
'Hinweis setzen (damit eine Hilfe für die Mitarbeiteranlegung im laufenden Jahr gegeben ist) _
'rngFirstDay.Offset(-1) = "x"
lCol = rngFirstDay.Column  'Einfügespalte
iOffset = rngFirstDay.Row + 1
For Each rngZelle In .Range(.Cells(6, 2), .Cells(.Rows.Count, 2).End(xlUp))
Select Case rngZelle.Value
Case "A": lRow = 4
Case "B": lRow = 5
Case "C": lRow = 6
Case "D": lRow = 7
Case "E": lRow = 8
End Select
iOffset = iOffset + 1
With wksHilfe
.Range(.Cells(lRow, 3), .Cells(lRow, 37)).Copy
End With
.Paste .Cells(iOffset, lCol)
Next rngZelle
End With
Application.CutCopyMode = False
Hide
End Sub

Gruß
Rudi
Anzeige

Links zu Excel-Dialogen

CommandButton TextBox

Beliebteste Forumthreads (12 Monate)

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

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige