AW: Wer kann mir helfen ein VBA Script zu ändern?
Darkman
OK dann ist hier das Script...
Es reicht allerdings nicht die Zeile if Arbeitvorrat> 8.25 Then.. zu ändern das habe ich schon probiert.
Vielen Dank schon mal...
Option Explicit
Sub Arbeitsplan()
Dim lZeile
Dim lSpalte
Dim i
Dim Arbeitsvorrat
Dim Startzeit
Dim Endzeit
Dim Tagesstunden
Dim bstartZeile As Boolean
Dim rowCount As Integer
Cells(1, 7).EntireColumn.Insert 'Spalte Tagesstunden einfügen
Cells(1, 7) = "Tagesstunden"
Cells(1, 17).EntireColumn.Insert 'Spalte Kennzeichen einfügen
Cells(1, 17) = "Kennzeichen"
lZeile = Cells(65000, 1).End(xlUp).Row
lSpalte = Cells(1, 200).End(xlToLeft).Column
For i = 2 To lZeile
DoEvents
Cells(i, 2) = TimeValue(Cells(i, 2)) * 24
Cells(i, 4) = TimeValue(Cells(i, 4)) * 24
Cells(i, 8) = Cells(i, 8) / Cells(i, 10)
Next i
i = 2
bstartZeile = True
Do While i <= lZeile
DoEvents
Arbeitsvorrat = Cells(i, 8)
If bstartZeile = True Then '****** 1. Zeile *****
rowCount = i + 1
If Arbeitsvorrat > (15 - Cells(i, 2)) Then
Cells(rowCount, 1).EntireRow.Insert
Range(Cells(i, 1), Cells(i, lSpalte)).Copy
Range(Cells(rowCount, 1), Cells(rowCount, lSpalte)).PasteSpecial xlValues
Application.CutCopyMode = False
Cells(rowCount, 3) = Cells(rowCount, 1) 'Enddatum = Startdatum
Cells(i, 17) = "O"
Startzeit = Cells(rowCount, 2)
If Arbeitsvorrat > 8.25 Then
If Startzeit + Arbeitsvorrat > 15 Then
Endzeit = Startzeit + Arbeitsvorrat
Arbeitsvorrat = Endzeit - 15
Cells(rowCount, 8) = Arbeitsvorrat
Endzeit = 15
Cells(rowCount, 4) = Endzeit
Tagesstunden = Endzeit - Startzeit
Cells(rowCount, 7) = Tagesstunden
Else
Endzeit = Startzeit + Arbeitsvorrat
Cells(rowCount, 4) = Endzeit
Tagesstunden = Endzeit - Startzeit
Cells(rowCount, 7) = Tagesstunden
Arbeitsvorrat = Arbeitsvorrat - Tagesstunden
End If
Else
If Startzeit + Arbeitsvorrat > 15 Then
Endzeit = Startzeit + Arbeitsvorrat
Arbeitsvorrat = Endzeit - 15
Cells(rowCount, 8) = Arbeitsvorrat
Endzeit = 15
Cells(rowCount, 4) = Endzeit
Tagesstunden = Endzeit - Startzeit
Cells(rowCount, 7) = Tagesstunden
Else
Endzeit = Startzeit + Arbeitsvorrat
Cells(rowCount, 4) = Endzeit
Tagesstunden = Endzeit - Startzeit
Cells(rowCount, 7) = Tagesstunden
Arbeitsvorrat = Arbeitsvorrat - Tagesstunden
End If
End If
If Arbeitsvorrat = 0 Then
bstartZeile = True
Else
bstartZeile = False
End If
Cells(rowCount, 8) = Arbeitsvorrat
Else
End If
lZeile = Cells(65000, 1).End(xlUp).Row
Else '***** restliche Zeilen ******
rowCount = i + 1
Do While Arbeitsvorrat > 0
DoEvents
Cells(rowCount, 1).EntireRow.Insert
Range(Cells(rowCount - 1, 1), Cells(rowCount - 1, lSpalte)).Copy
Range(Cells(rowCount, 1), Cells(rowCount, lSpalte)).PasteSpecial xlValues
Application.CutCopyMode = False
If Weekday(Cells(rowCount, 1), 2) = 5 Then
Cells(rowCount, 1) = Cells(rowCount, 1) + 3 'Wochenende überspringen
Else: Cells(rowCount, 1) = Cells(rowCount, 1) + 1 'Datum ein Tag weiterzählen
End If
Startzeit = 6.75
Cells(rowCount, 2) = Startzeit
Cells(rowCount, 3) = Cells(rowCount, 1) 'Enddatum = Startdatum
If Arbeitsvorrat > 6 Then
Endzeit = 15
Cells(rowCount, 4) = Endzeit
Else
Endzeit = Startzeit + Arbeitsvorrat
Cells(rowCount, 4) = Endzeit
End If
Tagesstunden = Endzeit - Startzeit
Cells(rowCount, 7) = Tagesstunden
Arbeitsvorrat = Arbeitsvorrat - Tagesstunden
Cells(rowCount, 8) = Arbeitsvorrat
rowCount = rowCount + 1
If Arbeitsvorrat = 0 Then
bstartZeile = True
i = rowCount - 1
Else
bstartZeile = False
End If
Loop
lZeile = Cells(65000, 1).End(xlUp).Row
End If
If i > lZeile Then
i = lZeile
Else
i = i + 1
End If
Loop
lZeile = Cells(65000, 1).End(xlUp).Row
Range(Cells(2, 2), Cells(lZeile, 2)).NumberFormat = "#,##0.00"
Range(Cells(2, 4), Cells(lZeile, 4)).NumberFormat = "#,##0.00"
Range(Cells(2, 7), Cells(lZeile, 7)).NumberFormat = "#,##0.00"
Range(Cells(2, 8), Cells(lZeile, 8)).NumberFormat = "#,##0.00"
For i = 2 To lZeile
DoEvents
Cells(i, 2) = Cells(i, 2) / 24
Cells(i, 2).NumberFormat = "hh:mm"
Cells(i, 4) = Cells(i, 4) / 24
Cells(i, 4).NumberFormat = "hh:mm"
Next i
lZeile = Cells(65000, 1).End(xlUp).Row
lSpalte = Cells(1, 200).End(xlToLeft).Column
Cells(1, 18).EntireColumn.Insert 'Spalte Kennzeichen einfügen
Cells(1, 18) = "CATS-Stunden"
For i = 2 To lZeile
DoEvents
If Cells(i, 7) > 0 Then
Cells(i, 18) = Cells(i, 7) * Cells(i, 10)
Else
Cells(i, 18) = Cells(i, 8) * Cells(i, 10)
End If
Next i
lZeile = Cells(65000, 1).End(xlUp).Row
lSpalte = Cells(1, 200).End(xlToLeft).Column
Columns("H:H").Select
Selection.Copy
Columns("R:R").Select
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Columns("R:R").Select 'überflüssige Spalten löschen
Selection.Cut
Columns("H:H").Select
Selection.Insert Shift:=xlToRight
Columns("G:G").Select
Selection.Delete Shift:=xlToLeft
Columns("H:H").Select
Selection.Delete Shift:=xlToLeft
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Columns("G:G").Select
Selection.Delete Shift:=xlToLeft
Columns("H:H").Select
Selection.Cut
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
Columns("A:N").Select 'Sortierung
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
, Order2:=xlAscending, Key3:=Range("C2"), Order3:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
lZeile = Cells(65000, 1).End(xlUp).Row
lSpalte = Cells(1, 200).End(xlToLeft).Column
Cells(1, 1).EntireColumn.Insert 'Spalte Wochentag einfügen
Cells(1, 1) = "Tag"
Range("B1").Select
Selection.Copy
Range("A1").Select
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
For i = 2 To lZeile 'Wochentage berechnen
DoEvents
If Weekday(Cells(i, 2), 2) = 1 Then
Cells(i, 1) = "Montag"
Else
If Weekday(Cells(i, 2), 2) = 2 Then
Cells(i, 1) = "Dienstag"
Else
If Weekday(Cells(i, 2), 2) = 3 Then
Cells(i, 1) = "Mittwoch"
Else
If Weekday(Cells(i, 2), 2) = 4 Then
Cells(i, 1) = "Donnerstag"
Else
If Weekday(Cells(i, 2), 2) = 5 Then
Cells(i, 1) = "Freitag"
Else
If Weekday(Cells(i, 2), 2) = 6 Then
Cells(i, 1) = "Samstag"
Else
If Weekday(Cells(i, 2), 2) = 7 Then
Cells(i, 1) = "Sonntag"
End If
End If
End If
End If
End If
End If
End If
Next i
Range("A1").Select 'Rasterformat einrichten
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range("A1").Select 'Summenzeilen ausblenden
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFilter
Selection.AutoFilter Field:=15, Criteria1:="="
Range("A1").Select
Columns("A:P").Select
Columns("A:P").EntireColumn.AutoFit
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Font.Bold = True
End Sub