Hallo,
ich habe eine Excel-Datei mit Makros vorliegen, die zur Erstellung von Arbeitszeit-Tagebüchern gedacht ist.
Der Aufbau ist wie folgt:
1. Tabellenblatt: Liste der Mitarbeiter
2. Tabellenblatt: Monatsübersicht der Arbeitszeiten
3. Tabellenblatt und Folgende: entsprechende Kalenderwochen (Übersicht der Arbeitszeiten im Detail für jede Woche)
Sinn ist, dass pro Mitarbeiter eine individuelle Datei erstellt wird, in der dann die Arbeitszeiten händisch
eingetragen werden können.
Das Script funktioniert, nur wurde kurzlich eine Änderung im "Layout" eingeführt, die dann logischerweise für alle Mitarbeiter
nach starten des Scripts übernommen werden soll.
Nur das passiert nicht. Die neuen Formeln werden nach Ausführung des Scripts nicht aus der Vorlage in die individuellen
Mitarbeiter-Excelsheets übernommen.
Leider habe ich von VBA nicht viel Ahnung und nicht die Zeit, mich in den Code einzuarbeiten. Der Code stammt nicht von mir und
der eigentliche Autor ist nicht erreichbar.
Evtl. kann mir hier jemand helfen, wie ich es schaffe, dass die Formeln aus der Vorlage nach Ausführung des Scripts in die Dateien
pro Mitarbeiter übernommen werden!
Danke im Voraus!
SCRIPT:
Public Function erster_Montag(Monat As Integer, Jahr As Integer) As Currency
Dim Datum As Long
Datum = DateSerial(Jahr, Monat, 1)
If Application.WorksheetFunction.Weekday(Datum, 2) = 1 Then
erster_Montag = Datum
Exit Function
End If
If Application.WorksheetFunction.Weekday(Datum, 2) = 7 Then
erster_Montag = DateSerial(Jahr, Monat, 2)
Exit Function
End If
If Application.WorksheetFunction.Weekday(Datum, 2) = 6 Then
erster_Montag = DateSerial(Jahr, Monat, 3)
Exit Function
End If
i = -1
Do
i = i + 1
Datum = DateSerial(Jahr, Monat - 1, 31 - i)
Loop Until Application.WorksheetFunction.Weekday(Datum, 2) = 1
''If Application.WorksheetFunction.Weekday(DateSerial(Jahr, Monat, 1), 1) = 1 Then Datum = Datum + 7
erster_Montag = Datum
End Function
Sub SchutzAufheben()
Dim Page, Seite, Var As Integer
Seite = ActiveSheet.Index
Page = ActiveWorkbook.Worksheets.Count
Var = 0
Do
Var = Var + 1
Sheets(Var).Unprotect
Loop Until Var = Page
Sheets(Seite).Select
End Sub
Sub SchutzSetzen()
Dim Page, Seite, Var As Integer
Seite = ActiveSheet.Index
Page = ActiveWorkbook.Worksheets.Count
Var = 0
Do
Var = Var + 1
Sheets(Var).Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Loop Until Var = 2
Do
Var = Var + 1
Sheets(Var).Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
:=True, AllowDeletingColumns:=True, AllowDeletingRows:=True
Loop Until Var = Page
Sheets(Seite).Select
End Sub
Sub Tagebücher_erstellen()
Dim Mitarbeiter(200, 10) 'begin of month not 1.
Dim a, Anz_Eigenschaften, d, day, i, l, Page, s, z, bmnf, dpm As Integer
Dim Datum As Double 'days per month
Dim erster_Montag, funktion, name, strPfad, RootPath As String
Dim First, found, smart As Boolean ' " + Neue Tagebücher\
Dim Montag As Variant
Dim objFSO As Object
Dim objFolder As Object
Dim objSubfolder As Object, colSubfolders As Object
Dim tribool, Adresse, Cache As Integer
Dim Mitarbeiteradresse(200, 1)
Dim Overlap As Integer
If MsgBox("Tagebücher in den entsprechenden Mitarbeiterordner speichern ?", vbYesNo) = vbNo Then
smart = False
Else
If MsgBox("Sind Sie sicher, dass Sie die Tagebücher in die Mitarbeiterordner speichern wollen ?", vbYesNo) = vbYes Then smart = True Else smart = False
End If
RootPath = ThisWorkbook.Path + "\Neue Tagebücher\"
Call SchutzAufheben
Sheets(3).Range("B3").FormulaR1C1 = "=Übersicht!RC"
Sheets(3).Range("C3").FormulaR1C1 = "=Übersicht!RC"
i = 3
Do
i = i + 1
If i > 100 Then
MsgBox ("Funktion 'erster_Montag' nicht vorhanden.")
Exit Sub
End If
Loop Until Sheets(2).Cells(i, 5).Formula Like "*erster_Montag*"
Montag = Sheets(2).Cells(i, 5).Address
d = 0
i = 13
Do
d = d + 1
i = i + 1
Datum = DateSerial(Sheets(3).Cells(3, 3).Value, Sheets(3).Cells(3, 2).Value, d)
Sheets(3).Cells(i, 2).Value = Datum
Sheets(3).Cells(i, 2).NumberFormat = "dd/mm/yy"
If i > 40 Then
With Sheets(3).Cells(i, 2).Interior
.Pattern = xlSolid
.TintAndShade = -0.149998474074526
End With
End If
Loop Until Month(Datum + 1) <> Sheets(3).Cells(3, 2).Value
If i < 44 Then
Do
i = i + 1
Sheets(3).Cells(i, 2).Value = ""
With Sheets(3).Cells(i, 2).Interior
.Pattern = xlNone
.TintAndShade = 0
End With
Loop Until i >= 44
End If
Sheets(3).Range("C14:AE44").Interior.Pattern = xlNone
i = 13
Do
i = i + 1
Sheets(3).Cells(i, 26).Value = "=E3"
Loop Until i = 44
i = 13
Do
i = i + 1
If Sheets(3).Cells(i, 2).Value = 0 Then
Sheets(3).Cells(i, 3).Value = ""
Else:
Select Case Application.WorksheetFunction.Weekday(Sheets(3).Cells(i, 2).Value, 1)
Case 1
Sheets(3).Cells(i, 3).Value = "Sonntag"
With Sheets(3).Range(Sheets(3).Cells(i, 3), Sheets(3).Cells(i, 31)).Interior
.Pattern = xlSolid
.TintAndShade = -0.149998474074526
End With
Sheets(3).Cells(i, 26).Value = ""
Case 2
Sheets(3).Cells(i, 3).Value = "Mo"
Case 3
Sheets(3).Cells(i, 3).Value = "Di"
Case 4
Sheets(3).Cells(i, 3).Value = "Mi"
Case 5
Sheets(3).Cells(i, 3).Value = "Do"
Case 6
Sheets(3).Cells(i, 3).Value = "Fr"
Case 7
Sheets(3).Cells(i, 3).Value = "Samstag"
Sheets(3).Cells(i, 26).Value = ""
End Select
'''''''''''''
''Feiertage''
'''''''''''''
If ((Format(Sheets(3).Cells(i, 2).Value, "DD") = 1 And Format(Sheets(3).Cells(i, 2).Value, "MM") = 1) _
Or (Format(Sheets(3).Cells(i, 2).Value, "DD") = 18 And Format(Sheets(3).Cells(i, 2).Value, "MM") = 4) _
Or (Format(Sheets(3).Cells(i, 2).Value, "DD") = 21 And Format(Sheets(3).Cells(i, 2).Value, "MM") = 4) _
Or (Format(Sheets(3).Cells(i, 2).Value, "DD") = 1 And Format(Sheets(3).Cells(i, 2).Value, "MM") = 5) _
Or (Format(Sheets(3).Cells(i, 2).Value, "DD") = 29 And Format(Sheets(3).Cells(i, 2).Value, "MM") = 5) _
Or (Format(Sheets(3).Cells(i, 2).Value, "DD") = 9 And Format(Sheets(3).Cells(i, 2).Value, "MM") = 6) _
Or (Format(Sheets(3).Cells(i, 2).Value, "DD") = 3 And Format(Sheets(3).Cells(i, 2).Value, "MM") = 10) _
Or (Format(Sheets(3).Cells(i, 2).Value, "DD") = 25 And Format(Sheets(3).Cells(i, 2).Value, "MM") = 12) _
Or (Format(Sheets(3).Cells(i, 2).Value, "DD") = 26 And Format(Sheets(3).Cells(i, 2).Value, "MM") = 12)) Then
With Sheets(3).Range(Sheets(3).Cells(i, 3), Sheets(3).Cells(i, 31)).Interior
.Pattern = xlSolid
.TintAndShade = -0.149998474074526
End With
Sheets(3).Cells(i, 26).Value = ""
End If
End If
Loop Until Month(Sheets(3).Cells(i, 2).Value + 1) <> Sheets(3).Cells(3, 2).Value
Sheets(3).Range("Y39").AutoFill Destination:=Sheets(3).Range("Y39:Y44"), Type:=xlFillValues
Sheets(3).Range("AB39").AutoFill Destination:=Sheets(3).Range("AB39:AB44"), Type:=xlFillValues
Sheets(3).Range("AC39").AutoFill Destination:=Sheets(3).Range("AC39:AC44"), Type:=xlFillValues
day = i
dpm = i
Sheets(3).Cells(45, 29).Value = "=AC" & i
If i < 44 Then
Do
i = i + 1
Sheets(3).Cells(i, 26).ClearContents
Sheets(3).Cells(i, 29).ClearContents
Loop Until i = 44
End If
i = day
If i < 44 Then
Do
i = i + 1
Sheets(3).Cells(i, 3).Value = ""
Loop Until i = 44
End If
i = 13
Do
i = i + 1
If Sheets(3).Cells(i, 2).Value >= Sheets(2).Range(Montag).Value Then
day = i
Exit Do
End If
Loop
Page = ActiveWorkbook.Worksheets.Count
If Page < 8 Then
Do
Application.DisplayAlerts = False
Sheets(Page).Copy After:=Sheets(Page)
Application.DisplayAlerts = True
Page = Page + 1
Loop Until Page = 8
End If
i = 3
Page = ActiveWorkbook.Worksheets.Count
Do
i = i + 1 ''+4 cause Jan. Week supposed to start with 1.
Sheets(i).Range("E7:F7").FormulaR1C1 = "=WEEKNUM(R[7]C[-1]+4)&"". KW ""&Übersicht!R[-4]C[-2]"
''"=Übersicht!R[" & Range(Montag).Row - 6 & "]C[" & Range(Montag).Column - 4 & "]+((R[50]C)-1) &"". KW ""&Übersicht!R[-4]C[-1]"
Loop Until i = Page
i = 3
Do
i = i + 1
Sheets(i).Range("E68").Value = i - 3
Loop Until i = Page
i = 3
Do
i = i + 1
Sheets(i).name = i
Loop Until i = Page
Sheets(3).Range("D14:I44").ClearContents
i = 40
Do
i = i + 1
If Sheets(3).Cells(i, 2).Value = 0 Then Sheets(3).Range(Sheets(3).Cells(i, 3), Sheets(3).Cells(i, 7)).Value = ""
Loop Until i > 43 'from i = 40 to this line probably unnecessary
With Sheets(3).Range("K:K").Interior
.Pattern = xlNone
.TintAndShade = 0
End With
With Sheets(3).Range("Y:Y").Interior
.Pattern = xlNone
.TintAndShade = 0
End With
With Sheets(3).Range("AD:AD").Interior
.Pattern = xlNone
.TintAndShade = 0
End With
Page = ActiveWorkbook.Worksheets.Count
For i = 4 To Page
Sheets(i).Range("E14:G20").ClearContents
If Mid$(Sheets(i).Cells(7, 5).Value, 2, 1) = "." Then
Sheets(i).name = "KW " & Left(Sheets(i).Cells(7, 5).Value, 1)
Else:
Sheets(i).name = "KW " & Left(Sheets(i).Cells(7, 5).Value, 2)
End If
Next i
If Month(Sheets(4).Cells(14, 4).Value) < Sheets(2).Cells(3, 2).Value Then
Sheets(4).Cells(7, 5).Copy
Sheets(4).Cells(7, 5).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
If Mid$(Sheets(4).Cells(7, 5).Value, 2, 1) = "." Then
Sheets(4).Cells(7, 5).Value = Left(Sheets(4).Cells(7, 5).Value, 2) & 2 & Right(Sheets(4).Cells(7, 5).Value, Len(Sheets(4).Cells(7, 5).Value) - 2)
Sheets(4).name = "KW " & Left(Sheets(4).Cells(7, 5).Value, 3)
Else:
Sheets(4).Cells(7, 5).Value = Left(Sheets(4).Cells(7, 5).Value, 3) & 2 & Right(Sheets(4).Cells(7, 5).Value, Len(Sheets(4).Cells(7, 5).Value) - 3)
Sheets(4).name = "KW " & Left(Sheets(4).Cells(7, 5).Value, 4)
End If
End If
If Month(Sheets(Page).Cells(19, 4).Value) > Sheets(2).Cells(3, 2).Value Then
Sheets(Page).Cells(7, 5).Copy
Sheets(Page).Cells(7, 5).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
If Mid$(Sheets(Page).Cells(7, 5).Value, 2, 1) = "." Then
Sheets(Page).Cells(7, 5).Value = Left(Sheets(Page).Cells(7, 5).Value, 2) & 1 & Right(Sheets(Page).Cells(7, 5).Value, Len(Sheets(Page).Cells(7, 5).Value) - 2)
Sheets(Page).name = "KW " & Left(Sheets(Page).Cells(7, 5).Value, 3)
Else:
Sheets(Page).Cells(7, 5).Value = Left(Sheets(Page).Cells(7, 5).Value, 3) & 1 & Right(Sheets(Page).Cells(7, 5).Value, Len(Sheets(Page).Cells(7, 5).Value) - 3)
Sheets(Page).name = "KW " & Left(Sheets(Page).Cells(7, 5).Value, 4)
End If
End If
'''''''''''''
bmnf = 0
Overlap = -1
Do
Overlap = Overlap + 1
If Overlap > 6 Then
bmnf = bmnf + 1
Overlap = 0
End If
Loop Until ((1 * Format(Sheets(4).Cells(14 + Overlap, 4).Value, "DD")) < (2 + bmnf))
For Page = 4 To ActiveWorkbook.Worksheets.Count
For i = 14 To 20 'check next month if bmnf works properly
If (((Page = 4) And ((1 * Format(Sheets(4).Cells(i, 4).Value, "DD")) < 8 + bmnf)) Or ((Page > 4) And (i + 7 * (Page - 4) - Overlap <= dpm))) Then
Sheets(Page).Cells(i, 5).FormulaR1C1 = _
"=IF(Projektkarte!R[" & 7 * (Page - 4) - Overlap + bmnf & "]C[-1]=0,"""",Projektkarte!R[" & 7 * (Page - 4) - Overlap + bmnf & "]C[-1])"
Sheets(Page).Cells(i, 6).FormulaR1C1 = _
"=IF(Projektkarte!R[" & 7 * (Page - 4) - Overlap + bmnf & "]C[1]=0,"""",Projektkarte!R[" & 7 * (Page - 4) - Overlap + bmnf & "]C[1])"
Sheets(Page).Cells(i, 7).FormulaR1C1 = _
"=IF(OR(Projektkarte!R[" & 7 * (Page - 4) - Overlap + bmnf & "]C[-2]=0,Projektkarte!R[" & 7 * (Page - 4) - Overlap + bmnf & "]C[-1]=0),"""",Projektkarte!R[" & 7 * (Page - 4) - Overlap + bmnf & "]C[-1]-Projektkarte!R[" & 7 * (Page - 4) - Overlap + bmnf & "]C[-2])"
End If
Next i
Next Page
If Month(Sheets(ActiveWorkbook.Worksheets.Count).Cells(14, 4).Value) > Sheets(2).Cells(3, 2).Value Then
Application.DisplayAlerts = False
Sheets(ActiveWorkbook.Worksheets.Count).Delete
Application.DisplayAlerts = True
End If
'''''''''''''''''''''''''''
ActiveWorkbook.Save
Call SchutzAufheben
i = 3
Do
i = i + 1
If i > 100 Then
MsgBox ("Funktion 'erster_Montag' nicht vorhanden.")
Exit Sub
End If
Loop Until Sheets(2).Cells(i, 5).Formula Like "*erster_Montag*"
Montag = Sheets(2).Cells(i, 5).Address
i = 3
Do
i = i + 1
If i > 100 Then
MsgBox ("Funktion '=KALENDERWOCHE()' nicht vorhanden.")
Exit Sub
End If
Loop Until Sheets(2).Cells(i, 5).Formula Like "*WEEKNUM*"
Sheets(2).Cells(i, 5).Copy
Sheets(2).Cells(i, 5).PasteSpecial Paste:=xlPasteValues
Page = ActiveWorkbook.Worksheets.Count
i = 3
Do
i = i + 1
Sheets(i).name = Left(Sheets(i).Cells(7, 5).Value, Len(Sheets(i).Cells(7, 5).Value) - 5)
Loop Until i = Page
Sheets(2).Outline.ShowLevels RowLevels:=2
erster_Montag = Sheets(1).Range(Montag).Value
i = 0
s = 0
z = 0
Do
s = s + 1
Mitarbeiter(z, s) = Sheets(1).Cells(z + 3, s + 1).Value
If z = 3 Then i = i + 1
Loop Until Sheets(1).Cells(z + 3, s + 2).Value = 0
Anz_Eigenschaften = s
z = -1
Do
s = 0
z = z + 1
Do
s = s + 1
Mitarbeiter(z, s) = Sheets(1).Cells(z + 3, s + 1).Value
If z = 3 Then i = i + 1
Loop Until s = Anz_Eigenschaften
Loop Until Sheets(1).Cells(z + 4, 2).Value = 0
Call SchutzAufheben
Application.DisplayAlerts = False
Sheets(1).Delete
Application.DisplayAlerts = True
For Page = 3 To ActiveWorkbook.Sheets.Count
Sheets(Page).Select
Sheets(Page).Range("D14:D20").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Sheets(Page).Range("E7:F7").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Next Page
Sheets(1).Select
Sheets(1).Range("A1").Select
Sheets(1).Rows("22:28").Delete Shift:=xlUp
z = 0
''''''''''''''''''''''''''''''''''''
If smart Then
strPfad = Left(ThisWorkbook.Path, Len(ThisWorkbook.Path) - 22) + "\Flughafen Schönefeld FGT Los 5\Bautagebuch"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strPfad)
Set colSubfolders = objFolder.Subfolders
Adresse = -1
For Each objSubfolder In colSubfolders
If IsError(Application.Match(objSubfolder.name, Columns(1), 0)) Then
Adresse = Adresse + 1
Mitarbeiteradresse(Adresse, 0) = objSubfolder.name
Mitarbeiteradresse(Adresse, 1) = objSubfolder.Path
End If
Next objSubfolder
Set objFolder = Nothing
Set colSubfolders = Nothing
Set objFSO = Nothing
End If
'''''''''''''''''''''''''''''''''''
If Dir(ThisWorkbook.Path & "\Neue Tagebücher\", vbDirectory) = "" Then
MkDir (ThisWorkbook.Path & "\Neue Tagebücher")
Else:
ChDir ThisWorkbook.Path & "\Neue Tagebücher"
End If
Application.DisplayAlerts = False
Call SchutzSetzen
Do
z = z + 1
s = 0
Sheets(1).Unprotect
Do
s = s + 1
Sheets(1).Range(Mitarbeiter(0, s)).Value = Mitarbeiter(z, s)
Loop Until s = i
Sheets(1).Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
''''''''''''''''''''''''''''''''' |
''check if autosort is possible'' |
''''''''''''''''''''''''''''''''' V
If smart Then
tribool = 0
Adresse = -1
Do
Adresse = Adresse + 1
If "*" + Mitarbeiter(z, 1) + "*" Like "*" + Mitarbeiteradresse(Adresse, 0) + "*" Then
If tribool = 1 Then tribool = 2
If tribool = 0 Then
tribool = 1
Cache = Adresse
End If
End If
Loop Until Adresse = 200 Or Mitarbeiteradresse(Adresse + 1, 0) = ""
''''''''''''''''''''''''''''''''
If tribool = 1 And Dir(Mitarbeiteradresse(Cache, 1) & "\Bautagebuch " & Format("1." & Sheets(2).Range("B3").Value & "." _
& Sheets(2).Range("C3").Value, "MMMM") & " " & Sheets(2).Range("C3").Value & " " & Mitarbeiter(z, 1) & ".xlsx") = "" Then
ActiveWorkbook.SaveAs Filename:= _
Mitarbeiteradresse(Cache, 1) & "\Bautagebuch " & Format("1." & Sheets(2).Range("B3").Value & "." _
& Sheets(2).Range("C3").Value, "MMMM") & " " & Sheets(2).Range("C3").Value & " " & Mitarbeiter(z, 1) & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End If
Else:
ActiveWorkbook.SaveAs Filename:= _
RootPath & "Bautagebuch " & Format("1." & Sheets(2).Range("B3").Value & "." _
& Sheets(2).Range("C3").Value, "MMMM") & " " & Sheets(2).Range("C3").Value & " " & Mitarbeiter(z, 1) & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End If
Loop Until ((Mitarbeiter(z + 1, 1) = 0) Or (Mitarbeiter(z + 1, 1) = ""))
Application.DisplayAlerts = False
Application.Quit
End Sub
|