Klassenmodul DieseArbeitsmappePrivate Sub Workbook_BeforeClose(cancel As Boolean)
On Error Resume Next
Application.EnableCancelKey = xlDisabled
Application.CommandBars("Arbeitszeit").Delete
Application.CommandBars("MeineArbeitszeit").Delete
Rem ThisWorkbook.Unprotect passw
Dim m As String
m = ThisWorkbook.Name
If (Environ("COMPUTERNAME") = ComPuterName1 And GetSetting("xxxxxx", "xxxxxx", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Or _
(Environ("COMPUTERNAME") = ComPuterName2 And GetSetting("xxxxxx", "xxxxxx", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Then
ActiveWorkbook.Save
ElseIf Sheets("xxxxxx").Range("F5").value = "" Or Sheets("xxxxxx").Range("F6").value = "" Or _
Sheets("xxxxxx").Range("F7").value = "" Or Sheets("xxxxxx").Range("F8").value = "" Or _
Sheets("xxxxxx").Range("K5").value = "" Then
Application.ScreenUpdating = False
Application.DisplayFormulaBar = True
Application.CommandBars("Cell").Enabled = True
Application.CommandBars("PLY").Enabled = True
Application.CommandBars("Row").Enabled = True
Application.CommandBars("Column").Enabled = True
Application.DisplayStatusBar = True
Sheets("xxxxxx").Visible = xlVeryHidden
Sheets("xxxxxx").Visible = xlVeryHidden
Sheets("xxxxxx").Visible = xlVeryHidden
Sheets("xxxxxx").Activate
ThisWorkbook.Protect passw
Application.ScreenUpdating = True
ActiveWorkbook.Save
ElseIf GetSetting("xxxxxx", "xxxxxx", m) <> m Then
Application.ScreenUpdating = False
SaveSetting "xxxxxx", "xxxxxx", m, m
Application.DisplayFormulaBar = True
Application.CommandBars("Cell").Enabled = True
Application.CommandBars("PLY").Enabled = True
Application.CommandBars("Row").Enabled = True
Application.CommandBars("Column").Enabled = True
Application.DisplayStatusBar = True
Sheets("xxxxxx").Visible = xlVeryHidden
Sheets("xxxxxx").Visible = xlVeryHidden
Sheets("xxxxxx").Visible = xlVeryHidden
Sheets("xxxxxx").Activate
ThisWorkbook.Protect passw
Application.ScreenUpdating = True
ActiveWorkbook.Save
Else
Application.ScreenUpdating = False
Sheets("xxxxxx").Visible = xlVeryHidden
Sheets("xxxxxx").Visible = xlVeryHidden
Sheets("xxxxxx").Visible = xlVeryHidden
Sheets("xxxxxx").Activate
Application.ScreenUpdating = True
Application.DisplayFormulaBar = True
Application.CommandBars("Cell").Enabled = True
Application.CommandBars("PLY").Enabled = True
Application.CommandBars("Row").Enabled = True
Application.CommandBars("Column").Enabled = True
Application.DisplayStatusBar = True
ThisWorkbook.Protect passw
Application.ScreenUpdating = True
ActiveWorkbook.Save
End If
End Sub
Private Sub workbook_open()
Application.EnableCancelKey = xlDisabled
On Error Resume Next
Dim blatt As Object
Dim m As String
m = ThisWorkbook.Name
For Each blatt In ActiveWorkbook.Sheets
With blatt
.Protect passw
.EnableSelection = xlUnlockedCells
End With
Next blatt
Sheets("xxxxxx").ScrollArea = "A1:C27"
Sheets("xxxxxx").ScrollArea = "A1:W22"
Sheets("xxxxxx").ScrollArea = "A1:AG1229"
Sheets("xxxxxx").ScrollArea = "A1:U80"
If (Environ("COMPUTERNAME") = ComPuterName1 And GetSetting("xxxxxx", "xxxxxx", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Or _
(Environ("COMPUTERNAME") = ComPuterName2 And GetSetting("xxxxxx", "xxxxxx", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Then GoTo Ende
If GetSetting("xxxxxx", "xxxxxx", "xxxxxx") <> "xxxxxx" Then userform1.Show
If GetSetting("xxxxxx", "xxxxxx", "xxxxxx") <> "xxxxxx" Or _
GetSetting("xxxxxx", "xxxxxx", m) <> ThisWorkbook.Name Then
Start:
Application.ScreenUpdating = False
ThisWorkbook.Unprotect passw
Sheets("xxxxxx").CommandButton1.Visible = True
Sheets("xxxxxx").Activate
Range("F5").Select
MsgBox "Sie müssen zuerst Ihre persönliche Daten und " & vbcrfl & _
"die notwendigen Zeitangaben eintragen!. " & vbCrLf & vbCrLf & _
"Klicken Sie zum Abschluß auf die Schaltfläche ""Einstellungen speichern""! " & vbCrLf & _
"Bis zur Speicherung der Angaben wird diese Seite " & _
"bei jedem Start angezeigt. ", vbOKOnly + vbExclamation, "Hinweis"
Sheets("xxxxxx").Visible = xlVeryHidden
Sheets("xxxxxx").Visible = xlVeryHidden
Sheets("xxxxxx").xlVeryHidden
Sheets("xxxxxx").Activate
Range("F5").Select
ActiveWindow.SmallScroll Down:=-1234
ThisWorkbook.Protect passw
Application.ScreenUpdating = True
Exit Sub
Else
Application.ScreenUpdating = False
ThisWorkbook.Unprotect passw
Sheets("xxxxxx").Visible = True
Sheets("xxxxxx").Visible = True
Sheets("xxxxxx").Visible = True
Sheets("xxxxxx").CommandButton1.Visible = False
Sheets("xxxxxx").Activate
ThisWorkbook.Protect passw
AZTab_FullBar34
On Error Resume Next
Dim i As Integer
For i = 18 To 19
Application.CommandBars("Arbeitszeit").Controls(i).Enabled = False
Next i
Application.CommandBars("Arbeitszeit").Protection = msoBarNoChangeVisible + msoBarNoCustomize _
+ msoBarNoChangeDock + msoBarNoMove + msoBarNoResize
Application.ScreenUpdating = True
Exit Sub
End If
Ende:
Application.ScreenUpdating = False
ActiveWorkbook.Unprotect passw
Sheets("xxxxxx").CommandButton1.Visible = True
Sheets("xxxxxx").Visible = True
Sheets("xxxxxx").Visible = True
Sheets("xxxxxx").Activate
Sheets("xxxxxx").Visible = True
ThisWorkbook.Protect passw
AZTab_FullBar34
On Error Resume Next
For i = 18 To 19
Application.CommandBars("Arbeitszeit").Controls(i).Enabled = False
Next i
Application.CommandBars("Arbeitszeit").Protection = msoBarNoChangeVisible + msoBarNoCustomize _
+ msoBarNoChangeDock + msoBarNoMove + msoBarNoResize
ArbeitTest
Application.CommandBars("MeineArbeitszeit").Protection = msoBarNoChangeVisible + msoBarNoCustomize _
+ msoBarNoChangeDock + msoBarNoMove + msoBarNoResize
Application.ScreenUpdating = True
End Sub
Private Sub Workbook_Activate()
On Error Resume Next
Dim c As Object
Application.EnableCancelKey = xlDisabled
If (Environ("COMPUTERNAME") = ComPuterName1 And GetSetting("xxxxxx", "xxxxxx", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Or _
(Environ("COMPUTERNAME") = ComPuterName2 And GetSetting("xxxxxx", "xxxxxx", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Then Exit Sub
Application.DisplayFormulaBar = False
Application.CommandBars("Cell").Enabled = False
Application.CommandBars("PLY").Enabled = False
Application.CommandBars("Row").Enabled = False
Application.CommandBars("Column").Enabled = False
Application.DisplayStatusBar = False
For Each c In Application.CommandBars
c.Enabled = False
Next
Application.CommandBars("Arbeitszeit").Enabled = True
End Sub
Private Sub Workbook_Deactivate()
On Error Resume Next
Dim c As Object
Application.EnableCancelKey = False
If (Environ("COMPUTERNAME") = ComPuterName1 And GetSetting("xxxxxx", "xxxxxx", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Or _
(Environ("COMPUTERNAME") = ComPuterName2 And GetSetting("xxxxxx", "xxxxxx", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Then Exit Sub
Application.DisplayFormulaBar = True
Application.CommandBars("Cell").Enabled = True
Application.CommandBars("PLY").Enabled = True
Application.CommandBars("Row").Enabled = True
Application.CommandBars("Column").Enabled = True
Application.DisplayStatusBar = True
For Each c In Application.CommandBars
c.Enabled = True
Next
Application.CommandBars("Arbeitszeit").Enabled = False
End Sub Klassenmodul Tabelle4Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, cancel As Boolean)
Rem If target.Address = "$X$10:$X$11" Then
Rem Cancel = True
Rem MsgBox "Mehrleistungsabbau wird nur berechnet, wenn bei Art " & vbCrLf & _
Rem "(Spalte 5) das Kürzel M angegeben wurde. Mehrleistungs- " & vbCrLf & _
Rem "abbau wird nicht als Arbeitszeit gerechnet, sondern vom " & vbCrLf & _
Rem "FZK/LZK auf das Arbeitszeitkonto übertragen. Die Jahres- " & vbCrLf & _
Rem "arbeitszeit reduziert sich entsprechend.", vbOKOnly + vbInformation, "Mehrleistung"
Rem Cancel = True
Rem Else
cancel = True
MsgBox "Die Zellformate dürfen nicht verändert werden. " & vbCrLf & _
"Der Doppelklick wurde deaktiviert." & vbCrLf & _
"Zugriff auf die Zellen verweigert. ", vbOKOnly + vbExclamation, "Hinweis"
Rem End If
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal target As Range, cancel As Boolean)
cancel = True
MsgBox "Die Zellformate dürfen nicht verändert werden. " & vbCrLf & _
"Die rechte Maustaste wurde deaktiviert." & vbCrLf & _
"Zugriff auf das Kontextmenü verweigert. ", vbOKOnly + vbExclamation, "Hinweis"
End Sub
Private Sub worksheet_activate()
On Error Resume Next
Dim i As Integer
For i = 1 To 13
Application.CommandBars("Arbeitszeit").Controls(i).Enabled = True
Next i
For i = 15 To 16
Application.CommandBars("Arbeitszeit").Controls(i).Enabled = True
Next i
If (Environ("COMPUTERNAME") = ComPuterName1 And GetSetting("xxxxxx", _
"xxxxxx", "xxxxxx") = GetSetting("xxxxxx", "AZTab01", "xxxxx")) Or _
(Environ("COMPUTERNAME") = ComPuterName2 And GetSetting("xxxxxx", _
"xxxxxx", "xxxxxx") = GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Then Exit Sub
ActiveWindow.DisplayWorkbookTabs = False
ActiveWindow.DisplayHeadings = False
End Sub
Private Sub worksheet_deactivate()
On Error Resume Next
Dim i As Integer
For i = 1 To 13
Application.CommandBars("Arbeitszeit").Controls(i).Enabled = False
Next i
For i = 15 To 16
Application.CommandBars("Arbeitszeit").Controls(i).Enabled = False
Next i
End Sub Klassenmodul Tabelle1Private Sub CommandButton1_Click()
Application.EnableCancelKey = False
Dim DistAZ As String
Dim DistYear As String
Dim DistMap As String
Dim m As String
Dim n As String
Dim x As String
n = ThisWorkbook.Name
m = Environ("USERNAME")
DistMap = m
DistAZ = "xxxxxx"
DistYear = Sheets("xxxxxx").Range("F4").value
If Sheets("xxxxxx").Range("F5").value = "" Or Sheets("xxxxxx").Range("F6").value = "" Or _
Sheets("xxxxxx").Range("F7").value = "" Or Sheets("xxxxxx").Range("F8").value = "" Or _
Sheets("xxxxxx").Range("K5").value = "" Then
MsgBox "Bitte vervollständigen Sie erst Ihre " & vbCrLf & _
"persönlichen Daten. Ohne diese Angaben " & vbCrLf & _
"können Sie die Einstellungen nicht speichern.", vbOKOnly + vbExclamation, "Warnung"
Else
Application.ScreenUpdating = False
x = ThisWorkbook.Name
SaveSetting "xxxxxx", "xxxxxx", "xxxxxx", DistAZ
SaveSetting "xxxxxx", "xxxxxx", "xxxxxx", DistYear
SaveSetting "xxxxxx", "xxxxxx", DistMap, DistMap
SaveSetting "xxxxxx", "xxxxxx", x, x
Sheets("xxxxxx").CommandButton1.Visible = False
ThisWorkbook.Unprotect passw
Sheets("xxxxxx").Visible = True
Sheets("xxxxxx").Visible = True
Sheets("xxxxxx").Visible = True
Sheets("xxxxxx").Activate
ActiveWorkbook.SaveAs ThisWorkbook.Sheets("xxxxxx").Range("K7").value
AZTab_FullBar34
On Error Resume Next
Dim i As Integer
For i = 18 To 19
Application.CommandBars("Arbeitszeit").Controls(i).Enabled = False
Next i
Application.CommandBars("Arbeitszeit").Protection = msoBarNoChangeVisible + _
msoBarNoCustomize + msoBarNoChangeDock + msoBarNoMove + msoBarNoResize
ThisWorkbook.Protect passw
Application.ScreenUpdating = True
End If
Ende:
End Sub
Private Sub worksheet_change(ByVal target As Range)
On Error GoTo Ende
If target.Address = "$F$4" Then Call Aendern
Ende:
End Sub
Private Sub worksheet_activate()
If (Environ("COMPUTERNAME") = ComPuterName1 And GetSetting("xxxxxx", "xxxxxx", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Or _
(Environ("COMPUTERNAME") = ComPuterName2 And GetSetting("xxxxxx", "xxxxxx", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Then Exit Sub
ActiveWindow.DisplayWorkbookTabs = False
ActiveWindow.DisplayHeadings = False
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, cancel As Boolean)
cancel = True
MsgBox "Die Zellformate dürfen nicht verändert werden. " & vbCrLf & _
"Der Doppelklick wurde deaktiviert." & vbCrLf & _
"Zugriff auf die Zellen verweigert. ", vbOKOnly + vbExclamation, "Hinweis"
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal target As Range, cancel As Boolean)
cancel = True
MsgBox "Die Zellformate dürfen nicht verändert werden. " & vbCrLf & _
"Die rechte Maustaste wurde deaktiviert." & vbCrLf & _
"Zugriff auf das Kontextmenü verweigert. ", vbOKOnly + vbExclamation, "Hinweis"
End Sub Klassenmodul Tabelle2Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, cancel As Boolean)
cancel = True
MsgBox "Die Zellformate dürfen nicht verändert werden. " & vbCrLf & _
"Der Doppelklick wurde deaktiviert." & vbCrLf & _
"Zugriff auf die Zellen verweigert. ", vbOKOnly + vbExclamation, "Hinweis"
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal target As Range, cancel As Boolean)
cancel = True
MsgBox "Die Zellformate dürfen nicht verändert werden. " & vbCrLf & _
"Die rechte Maustaste wurde deaktiviert." & vbCrLf & _
"Zugriff auf das Kontextmenü verweigert. ", vbOKOnly + vbExclamation, "Hinweis"
End Sub
Private Sub worksheet_activate()
If (Environ("COMPUTERNAME") = ComPuterName1 And GetSetting("xxxxxx", "xxxxxx", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Or _
(Environ("COMPUTERNAME") = ComPuterName2 And GetSetting("xxxxxx", "xxxxxx", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Then Exit Sub
ActiveWindow.DisplayWorkbookTabs = False
ActiveWindow.DisplayHeadings = False
End Sub Klassenmodul Tabelle3Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, cancel As Boolean)
cancel = True
MsgBox "Die Zellformate dürfen nicht verändert werden. " & vbCrLf & _
"Der Doppelklick wurde deaktiviert." & vbCrLf & _
"Zugriff auf die Zellen verweigert. ", vbOKOnly + vbExclamation, "Hinweis"
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal target As Range, cancel As Boolean)
cancel = True
MsgBox "Die Zellformate dürfen nicht verändert werden. " & vbCrLf & _
"Die rechte Maustaste wurde deaktiviert." & vbCrLf & _
"Zugriff auf das Kontextmenü verweigert. ", vbOKOnly + vbExclamation, "Hinweis"
End Sub
Private Sub worksheet_activate()
On Error Resume Next
Dim i As Integer
For i = 18 To 19
Application.CommandBars("Arbeitszeit").Controls(i).Enabled = True
Next i
Dim s As String
If (Environ("COMPUTERNAME") = ComPuterName1 And GetSetting("xxxxxx", "xxxxxx", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Or _
(Environ("COMPUTERNAME") = ComPuterName2 And GetSetting("xxxxxx", "xxxxxx", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Then Exit Sub
ActiveWindow.DisplayWorkbookTabs = False
ActiveWindow.DisplayHeadings = False
End Sub
Private Sub worksheet_deactivate()
On Error Resume Next
Dim i As Integer
For i = 18 To 19
Application.CommandBars("Arbeitszeit").Controls(i).Enabled = False
Next i
End Sub
Dialog userform2Option Explicit
Private Sub CommandButton1_Click()
TextBox7.Text = Format(CDbl(TextBox7.Text), "h:mm")
End Sub
Private Sub Label222_Click()
Application.ScreenUpdating = False
Dim iTage As Integer
Dim dZeit As Date
Dim iZeit As Integer
Dim iBeit As Integer
Dim iposit As Integer
Dim iposit2 As Integer
Dim iWoche As Integer
iWoche = TextBox2.value
iTage = CInt(TextBox1.value)
iposit = InStr(TextBox3.value, ":")
iposit2 = InStr(TextBox21.value, ":")
If iposit > 0 Then
iZeit = (CInt(Left(TextBox3.value, iposit - 1) * 60) + _
CInt(Right(TextBox3.value, Len(TextBox3.value) - iposit)))
Else
MsgBox "bitte eine gültige Zeitangabe (hh:mm) eingeben.", _
48, " " & Date & " Hinweis für " & Application.UserName
With TextBox2
.SetFocus
.SelStart = 0
.SelLength = Len(.Text)
End With
Exit Sub
End If
TextBox6.value = Format(Int(iZeit / iWoche * iTage / 60) + (iZeit / iWoche * iTage / 60 - _
Int(iZeit / iWoche * iTage / 60)) * 60 / 100, "#0.00")
TextBox6.value = Replace(TextBox6.value, ",", ":")
Dim iHH As Integer
Dim iMM As Integer
Dim iDD As Integer
iHH = GetTextBox6Value
TextBox24.value = iHH & ":00"
Sheets("xxxxxx").Unprotect passw
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = False
Sheets("xxxxxx").Range("D1").value = TextBox24.value
Sheets("xxxxxx").Range("D2").value = TextBox21.value
Sheets("xxxxxx").Range("D3").value = TextBox25.value
TextBox7.value = Sheets("xxxxxx").Range("D4").Text
TextBox21.value = ""
TextBox25.value = ""
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = True
Sheets("xxxxxx").Protect passw
Application.ScreenUpdating = False
End Sub
Private Sub Label223_Click()
On Error Resume Next
Application.ScreenUpdating = False
Dim iTage As Integer
Dim dZeit As Date
Dim iZeit As Integer
Dim iBeit As Integer
Dim iposit As Integer
Dim iposit2 As Integer
Dim iWoche As Integer
iWoche = TextBox2.value
iTage = CInt(TextBox1.value)
iposit = InStr(TextBox3.value, ":")
iposit2 = InStr(TextBox21.value, ":")
If iposit > 0 Then
iZeit = (CInt(Left(TextBox3.value, iposit - 1) * 60) + _
CInt(Right(TextBox3.value, Len(TextBox3.value) - iposit)))
Else
MsgBox "bitte eine gültige Zeitangabe (hh:mm) eingeben.", _
48, " " & Date & " Hinweis für " & Application.UserName
With TextBox2
.SetFocus
.SelStart = 0
.SelLength = Len(.Text)
End With
Exit Sub
End If
TextBox6.value = Format(Int(iZeit / iWoche * iTage / 60) + (iZeit / iWoche * iTage / 60 - _
Int(iZeit / iWoche * iTage / 60)) * 60 / 100, "#0.00")
TextBox6.value = Replace(TextBox6.value, ",", ":")
Dim iHH As Integer
Dim iMM As Integer
Dim iDD As Integer
iHH = GetTextBox6Value
TextBox24.value = iHH & ":00"
Sheets("xxxxxx").Unprotect passw
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = False
Sheets("xxxxxx").Range("D1").value = TextBox24.value
Sheets("xxxxxx").Range("D2").value = TextBox21.value
Sheets("xxxxxx").Range("D3").value = TextBox25.value
TextBox8.value = Sheets("xxxxxx").Range("D4").Text
TextBox21.value = ""
TextBox25.value = ""
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = True
Sheets("xxxxxx").Protect passw
Application.ScreenUpdating = False
End Sub
Private Sub Label224_Click()
On Error Resume Next
Application.ScreenUpdating = False
Dim iTage As Integer
Dim dZeit As Date
Dim iZeit As Integer
Dim iBeit As Integer
Dim iposit As Integer
Dim iposit2 As Integer
Dim iWoche As Integer
iWoche = TextBox2.value
iTage = CInt(TextBox1.value)
iposit = InStr(TextBox3.value, ":")
iposit2 = InStr(TextBox21.value, ":")
If iposit > 0 Then
iZeit = (CInt(Left(TextBox3.value, iposit - 1) * 60) + _
CInt(Right(TextBox3.value, Len(TextBox3.value) - iposit)))
Else
MsgBox "bitte eine gültige Zeitangabe (hh:mm) eingeben.", _
48, " " & Date & " Hinweis für " & Application.UserName
With TextBox2
.SetFocus
.SelStart = 0
.SelLength = Len(.Text)
End With
Exit Sub
End If
TextBox6.value = Format(Int(iZeit / iWoche * iTage / 60) + (iZeit / iWoche * iTage / 60 - _
Int(iZeit / iWoche * iTage / 60)) * 60 / 100, "#0.00")
TextBox6.value = Replace(TextBox6.value, ",", ":")
Dim iHH As Integer
Dim iMM As Integer
Dim iDD As Integer
iHH = GetTextBox6Value
TextBox24.value = iHH & ":00"
Sheets("xxxxxx").Unprotect passw
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = False
Sheets("xxxxxx").Range("D1").value = TextBox24.value
Sheets("xxxxxx").Range("D2").value = TextBox21.value
Sheets("xxxxxx").Range("D3").value = TextBox25.value
TextBox9.value = Sheets("xxxxxx").Range("D4").Text
TextBox21.value = ""
TextBox25.value = ""
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = True
Sheets("xxxxxx").Protect passw
Application.ScreenUpdating = False
End Sub
Private Sub Label225_Click()
On Error Resume Next
Application.ScreenUpdating = False
Dim iTage As Integer
Dim dZeit As Date
Dim iZeit As Integer
Dim iBeit As Integer
Dim iposit As Integer
Dim iposit2 As Integer
Dim iWoche As Integer
iWoche = TextBox2.value
iTage = CInt(TextBox1.value)
iposit = InStr(TextBox3.value, ":")
iposit2 = InStr(TextBox21.value, ":")
If iposit > 0 Then
iZeit = (CInt(Left(TextBox3.value, iposit - 1) * 60) + _
CInt(Right(TextBox3.value, Len(TextBox3.value) - iposit)))
Else
MsgBox "bitte eine gültige Zeitangabe (hh:mm) eingeben.", _
48, " " & Date & " Hinweis für " & Application.UserName
With TextBox2
.SetFocus
.SelStart = 0
.SelLength = Len(.Text)
End With
Exit Sub
End If
TextBox6.value = Format(Int(iZeit / iWoche * iTage / 60) + (iZeit / iWoche * iTage / 60 - _
Int(iZeit / iWoche * iTage / 60)) * 60 / 100, "#0.00")
TextBox6.value = Replace(TextBox6.value, ",", ":")
Dim iHH As Integer
Dim iMM As Integer
Dim iDD As Integer
iHH = GetTextBox6Value
TextBox24.value = iHH & ":00"
Sheets("xxxxxx").Unprotect passw
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = False
Sheets("xxxxxx").Range("D1").value = TextBox24.value
Sheets("xxxxxx").Range("D2").value = TextBox21.value
Sheets("xxxxxx").Range("D3").value = TextBox25.value
TextBox10.value = Sheets("xxxxxx").Range("D4").Text
TextBox21.value = ""
TextBox25.value = ""
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = True
Sheets("xxxxxx").Protect passw
Application.ScreenUpdating = False
End Sub
Private Sub Label226_Click()
On Error Resume Next
Application.ScreenUpdating = False
Dim iTage As Integer
Dim dZeit As Date
Dim iZeit As Integer
Dim iBeit As Integer
Dim iposit As Integer
Dim iposit2 As Integer
Dim iWoche As Integer
iWoche = TextBox2.value
iTage = CInt(TextBox1.value)
iposit = InStr(TextBox3.value, ":")
iposit2 = InStr(TextBox21.value, ":")
If iposit > 0 Then
iZeit = (CInt(Left(TextBox3.value, iposit - 1) * 60) + _
CInt(Right(TextBox3.value, Len(TextBox3.value) - iposit)))
Else
MsgBox "bitte eine gültige Zeitangabe (hh:mm) eingeben.", _
48, " " & Date & " Hinweis für " & Application.UserName
With TextBox2
.SetFocus
.SelStart = 0
.SelLength = Len(.Text)
End With
Exit Sub
End If
TextBox6.value = Format(Int(iZeit / iWoche * iTage / 60) + (iZeit / iWoche * iTage / 60 - _
Int(iZeit / iWoche * iTage / 60)) * 60 / 100, "#0.00")
TextBox6.value = Replace(TextBox6.value, ",", ":")
Dim iHH As Integer
Dim iMM As Integer
Dim iDD As Integer
iHH = GetTextBox6Value
TextBox24.value = iHH & ":00"
Sheets("xxxxxx").Unprotect passw
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = False
Sheets("xxxxxx").Range("D1").value = TextBox24.value
Sheets("xxxxxx").Range("D2").value = TextBox21.value
Sheets("xxxxxx").Range("D3").value = TextBox25.value
TextBox11.value = Sheets("xxxxxx").Range("D4").Text
TextBox21.value = ""
TextBox25.value = ""
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = True
Sheets("xxxxxx").Protect passw
Application.ScreenUpdating = False
End Sub
Private Sub Label227_Click()
On Error Resume Next
Application.ScreenUpdating = False
Dim iTage As Integer
Dim dZeit As Date
Dim iZeit As Integer
Dim iBeit As Integer
Dim iposit As Integer
Dim iposit2 As Integer
Dim iWoche As Integer
iWoche = TextBox2.value
iTage = CInt(TextBox1.value)
iposit = InStr(TextBox3.value, ":")
iposit2 = InStr(TextBox21.value, ":")
If iposit > 0 Then
iZeit = (CInt(Left(TextBox3.value, iposit - 1) * 60) + _
CInt(Right(TextBox3.value, Len(TextBox3.value) - iposit)))
Else
MsgBox "bitte eine gültige Zeitangabe (hh:mm) eingeben.", _
48, " " & Date & " Hinweis für " & Application.UserName
With TextBox2
.SetFocus
.SelStart = 0
.SelLength = Len(.Text)
End With
Exit Sub
End If
TextBox6.value = Format(Int(iZeit / iWoche * iTage / 60) + (iZeit / iWoche * iTage / 60 - _
Int(iZeit / iWoche * iTage / 60)) * 60 / 100, "#0.00")
TextBox6.value = Replace(TextBox6.value, ",", ":")
Dim iHH As Integer
Dim iMM As Integer
Dim iDD As Integer
iHH = GetTextBox6Value
TextBox24.value = iHH & ":00"
Sheets("xxxxxx").Unprotect passw
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = False
Sheets("xxxxxx").Range("D1").value = TextBox24.value
Sheets("xxxxxx").Range("D2").value = TextBox21.value
Sheets("xxxxxx").Range("D3").value = TextBox25.value
TextBox12.value = Sheets("xxxxxx").Range("D4").Text
TextBox21.value = ""
TextBox25.value = ""
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = True
Sheets("xxxxxx").Protect passw
Application.ScreenUpdating = False
End Sub
Private Sub Label228_Click()
On Error Resume Next
Application.ScreenUpdating = False
Dim iTage As Integer
Dim dZeit As Date
Dim iZeit As Integer
Dim iBeit As Integer
Dim iposit As Integer
Dim iposit2 As Integer
Dim iWoche As Integer
iWoche = TextBox2.value
iTage = CInt(TextBox1.value)
iposit = InStr(TextBox3.value, ":")
iposit2 = InStr(TextBox21.value, ":")
If iposit > 0 Then
iZeit = (CInt(Left(TextBox3.value, iposit - 1) * 60) + _
CInt(Right(TextBox3.value, Len(TextBox3.value) - iposit)))
Else
MsgBox "bitte eine gültige Zeitangabe (hh:mm) eingeben.", _
48, " " & Date & " Hinweis für " & Application.UserName
With TextBox2
.SetFocus
.SelStart = 0
.SelLength = Len(.Text)
End With
Exit Sub
End If
TextBox6.value = Format(Int(iZeit / iWoche * iTage / 60) + (iZeit / iWoche * iTage / 60 - _
Int(iZeit / iWoche * iTage / 60)) * 60 / 100, "#0.00")
TextBox6.value = Replace(TextBox6.value, ",", ":")
Dim iHH As Integer
Dim iMM As Integer
Dim iDD As Integer
iHH = GetTextBox6Value
TextBox24.value = iHH & ":00"
Sheets("xxxxxx").Unprotect passw
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = False
Sheets("xxxxxx").Range("D1").value = TextBox24.value
Sheets("xxxxxx").Range("D2").value = TextBox21.value
Sheets("xxxxxx").Range("D3").value = TextBox25.value
TextBox13.value = Sheets("xxxxxx").Range("D4").Text
TextBox21.value = ""
TextBox25.value = ""
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = True
Sheets("xxxxxx").Protect passw
Application.ScreenUpdating = False
End Sub
Private Sub Label229_Click()
On Error Resume Next
Application.ScreenUpdating = False
Dim iTage As Integer
Dim dZeit As Date
Dim iZeit As Integer
Dim iBeit As Integer
Dim iposit As Integer
Dim iposit2 As Integer
Dim iWoche As Integer
iWoche = TextBox2.value
iTage = CInt(TextBox1.value)
iposit = InStr(TextBox3.value, ":")
iposit2 = InStr(TextBox21.value, ":")
If iposit > 0 Then
iZeit = (CInt(Left(TextBox3.value, iposit - 1) * 60) + _
CInt(Right(TextBox3.value, Len(TextBox3.value) - iposit)))
Else
MsgBox "bitte eine gültige Zeitangabe (hh:mm) eingeben.", _
48, " " & Date & " Hinweis für " & Application.UserName
With TextBox2
.SetFocus
.SelStart = 0
.SelLength = Len(.Text)
End With
Exit Sub
End If
TextBox6.value = Format(Int(iZeit / iWoche * iTage / 60) + (iZeit / iWoche * iTage / 60 - _
Int(iZeit / iWoche * iTage / 60)) * 60 / 100, "#0.00")
TextBox6.value = Replace(TextBox6.value, ",", ":")
Dim iHH As Integer
Dim iMM As Integer
Dim iDD As Integer
iHH = GetTextBox6Value
TextBox24.value = iHH & ":00"
Sheets("xxxxxx").Unprotect passw
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = False
Sheets("xxxxxx").Range("D1").value = TextBox24.value
Sheets("xxxxxx").Range("D2").value = TextBox21.value
Sheets("xxxxxx").Range("D3").value = TextBox25.value
TextBox14.value = Sheets("xxxxxx").Range("D4").Text
TextBox21.value = ""
TextBox25.value = ""
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = True
Sheets("xxxxxx").Protect passw
Application.ScreenUpdating = False
End Sub
Private Sub Label230_Click()
On Error Resume Next
Application.ScreenUpdating = False
Dim iTage As Integer
Dim dZeit As Date
Dim iZeit As Integer
Dim iBeit As Integer
Dim iposit As Integer
Dim iposit2 As Integer
Dim iWoche As Integer
iWoche = TextBox2.value
iTage = CInt(TextBox1.value)
iposit = InStr(TextBox3.value, ":")
iposit2 = InStr(TextBox21.value, ":")
If iposit > 0 Then
iZeit = (CInt(Left(TextBox3.value, iposit - 1) * 60) + _
CInt(Right(TextBox3.value, Len(TextBox3.value) - iposit)))
Else
MsgBox "bitte eine gültige Zeitangabe (hh:mm) eingeben.", _
48, " " & Date & " Hinweis für " & Application.UserName
With TextBox2
.SetFocus
.SelStart = 0
.SelLength = Len(.Text)
End With
Exit Sub
End If
TextBox6.value = Format(Int(iZeit / iWoche * iTage / 60) + (iZeit / iWoche * iTage / 60 - _
Int(iZeit / iWoche * iTage / 60)) * 60 / 100, "#0.00")
TextBox6.value = Replace(TextBox6.value, ",", ":")
Dim iHH As Integer
Dim iMM As Integer
Dim iDD As Integer
iHH = GetTextBox6Value
TextBox24.value = iHH & ":00"
Sheets("xxxxxx").Unprotect passw
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = False
Sheets("xxxxxx").Range("D1").value = TextBox24.value
Sheets("xxxxxx").Range("D2").value = TextBox21.value
Sheets("xxxxxx").Range("D3").value = TextBox25.value
TextBox15.value = Sheets("xxxxxx").Range("D4").Text
TextBox21.value = ""
TextBox25.value = ""
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = True
Sheets("xxxxxx").Protect passw
Application.ScreenUpdating = False
End Sub
Private Sub Label231_Click()
On Error Resume Next
Application.ScreenUpdating = False
Dim iTage As Integer
Dim dZeit As Date
Dim iZeit As Integer
Dim iBeit As Integer
Dim iposit As Integer
Dim iposit2 As Integer
Dim iWoche As Integer
iWoche = TextBox2.value
iTage = CInt(TextBox1.value)
iposit = InStr(TextBox3.value, ":")
iposit2 = InStr(TextBox21.value, ":")
If iposit > 0 Then
iZeit = (CInt(Left(TextBox3.value, iposit - 1) * 60) + _
CInt(Right(TextBox3.value, Len(TextBox3.value) - iposit)))
Else
MsgBox "bitte eine gültige Zeitangabe (hh:mm) eingeben.", _
48, " " & Date & " Hinweis für " & Application.UserName
With TextBox2
.SetFocus
.SelStart = 0
.SelLength = Len(.Text)
End With
Exit Sub
End If
TextBox6.value = Format(Int(iZeit / iWoche * iTage / 60) + (iZeit / iWoche * iTage / 60 - _
Int(iZeit / iWoche * iTage / 60)) * 60 / 100, "#0.00")
TextBox6.value = Replace(TextBox6.value, ",", ":")
Dim iHH As Integer
Dim iMM As Integer
Dim iDD As Integer
iHH = GetTextBox6Value
TextBox24.value = iHH & ":00"
Sheets("xxxxxx").Unprotect passw
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = False
Sheets("xxxxxx").Range("D1").value = TextBox24.value
Sheets("xxxxxx").Range("D2").value = TextBox21.value
Sheets("xxxxxx").Range("D3").value = TextBox25.value
TextBox16.value = Sheets("xxxxxx").Range("D4").Text
TextBox21.value = ""
TextBox25.value = ""
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = True
Sheets("xxxxxx").Protect passw
Application.ScreenUpdating = False
End Sub
Private Sub Label232_Click()
On Error Resume Next
Application.ScreenUpdating = False
Dim iTage As Integer
Dim dZeit As Date
Dim iZeit As Integer
Dim iBeit As Integer
Dim iposit As Integer
Dim iposit2 As Integer
Dim iWoche As Integer
iWoche = TextBox2.value
iTage = CInt(TextBox1.value)
iposit = InStr(TextBox3.value, ":")
iposit2 = InStr(TextBox21.value, ":")
If iposit > 0 Then
iZeit = (CInt(Left(TextBox3.value, iposit - 1) * 60) + _
CInt(Right(TextBox3.value, Len(TextBox3.value) - iposit)))
Else
MsgBox "bitte eine gültige Zeitangabe (hh:mm) eingeben.", _
48, " " & Date & " Hinweis für " & Application.UserName
With TextBox2
.SetFocus
.SelStart = 0
.SelLength = Len(.Text)
End With
Exit Sub
End If
TextBox6.value = Format(Int(iZeit / iWoche * iTage / 60) + (iZeit / iWoche * iTage / 60 - _
Int(iZeit / iWoche * iTage / 60)) * 60 / 100, "#0.00")
TextBox6.value = Replace(TextBox6.value, ",", ":")
Dim iHH As Integer
Dim iMM As Integer
Dim iDD As Integer
iHH = GetTextBox6Value
TextBox24.value = iHH & ":00"
Sheets("xxxxxx").Unprotect passw
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = False
Sheets("xxxxxx").Range("D1").value = TextBox24.value
Sheets("xxxxxx").Range("D2").value = TextBox21.value
Sheets("xxxxxx").Range("D3").value = TextBox25.value
TextBox17.value = Sheets("xxxxxx").Range("D4").Text
TextBox21.value = ""
TextBox25.value = ""
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = True
Sheets("xxxxxx").Protect passw
Application.ScreenUpdating = False
End Sub
Private Sub Label233_Click()
On Error Resume Next
Application.ScreenUpdating = False
Dim iTage As Integer
Dim dZeit As Date
Dim iZeit As Integer
Dim iBeit As Integer
Dim iposit As Integer
Dim iposit2 As Integer
Dim iWoche As Integer
iWoche = TextBox2.value
iTage = CInt(TextBox1.value)
iposit = InStr(TextBox3.value, ":")
iposit2 = InStr(TextBox21.value, ":")
If iposit > 0 Then
iZeit = (CInt(Left(TextBox3.value, iposit - 1) * 60) + _
CInt(Right(TextBox3.value, Len(TextBox3.value) - iposit)))
Else
MsgBox "bitte eine gültige Zeitangabe (hh:mm) eingeben.", _
48, " " & Date & " Hinweis für " & Application.UserName
With TextBox2
.SetFocus
.SelStart = 0
.SelLength = Len(.Text)
End With
Exit Sub
End If
TextBox6.value = Format(Int(iZeit / iWoche * iTage / 60) + (iZeit / iWoche * iTage / 60 - _
Int(iZeit / iWoche * iTage / 60)) * 60 / 100, "#0.00")
TextBox6.value = Replace(TextBox6.value, ",", ":")
Dim iHH As Integer
Dim iMM As Integer
Dim iDD As Integer
iHH = GetTextBox6Value
TextBox24.value = iHH & ":00"
Sheets("xxxxxx").Unprotect passw
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = False
Sheets("xxxxxx").Range("D1").value = TextBox24.value
Sheets("xxxxxx").Range("D2").value = TextBox21.value
Sheets("xxxxxx").Range("D3").value = TextBox25.value
TextBox18.value = Sheets("xxxxxx").Range("D4").Text
TextBox21.value = ""
TextBox25.value = ""
Sheets("xxxxxx").Columns("D:D").EntireColumn.Hidden = True
Sheets("xxxxxx").Protect passw
Application.ScreenUpdating = False
End Sub
Private Sub Label22_Click()
On Error Resume Next
Application.ScreenUpdating = False
ThisWorkbook.Sheets("xxxxxx").Unprotect passw
Range("E6").Activate
ActiveCell.value = TextBox7.value
ActiveCell.Offset(0, 1).value = TextBox8.value
ActiveCell.Offset(0, 2).value = TextBox9.value
ActiveCell.Offset(0, 3).value = TextBox10.value
ActiveCell.Offset(0, 4).value = TextBox11.value
ActiveCell.Offset(0, 5).value = TextBox12.value
ActiveCell.Offset(0, 6).value = TextBox13.value
ActiveCell.Offset(0, 7).value = TextBox14.value
ActiveCell.Offset(0, 8).value = TextBox15.value
ActiveCell.Offset(0, 9).value = TextBox16.value
ActiveCell.Offset(0, 10).value = TextBox17.value
ActiveCell.Offset(0, 11).value = TextBox18.value
Application.ScreenUpdating = True
ThisWorkbook.Sheets("xxxxxx").Protect passw
Application.Calculate
End Sub
Private Sub Label20_Click()
On Error Resume Next
Application.ScreenUpdating = False
ThisWorkbook.Sheets("xxxxxx").Unprotect passw
Range("E6").Activate
ActiveCell.value = ""
ActiveCell.Offset(0, 1).value = ""
ActiveCell.Offset(0, 2).value = ""
ActiveCell.Offset(0, 3).value = ""
ActiveCell.Offset(0, 4).value = ""
ActiveCell.Offset(0, 5).value = ""
ActiveCell.Offset(0, 6).value = ""
ActiveCell.Offset(0, 7).value = ""
ActiveCell.Offset(0, 8).value = ""
ActiveCell.Offset(0, 9).value = ""
ActiveCell.Offset(0, 10).value = ""
ActiveCell.Offset(0, 11).value = ""
Application.ScreenUpdating = True
ThisWorkbook.Sheets("xxxxxx").Protect passw
End Sub
Private Sub Label21_Click()
Dim i As Integer
For i = 7 To 19
Me.Controls("TextBox" & i).value = ""
Next i
End Sub
Private Sub CommandButton32_Click()
Unload Me
End Sub
Private Sub Label19_Click()
Dim i1Zeit As Double
Dim i2Zeit As Double
i1Zeit = Val(TextBox7.value) + Val(TextBox8.value) + Val(TextBox9.value) + Val(TextBox10.value) _
+ Val(TextBox11.value) + _
Val(TextBox12.value) + Val(TextBox13.value) + Val(TextBox14.value) + Val(TextBox15.value) _
+ Val(TextBox16.value) _
+ Val(TextBox17.value) + Val(TextBox18.value) '+ Val(TextBox20.value)
TextBox19.value = Int(i1Zeit) & ":" & Format((i1Zeit - Int(i1Zeit)) * 60, "00")
End Sub
Private Sub CommandButton35_Click()
On Error Resume Next
Sheets("xxxxxx").Range("D1").value = TextBox7.value
Sheets("xxxxxx").Range("D2").value = TextBox21.value
TextBox7.value = Sheets("xxxxxx").Range("D3").Text
End Sub
Private Sub Label221_Click()
Unload Me
ThisWorkbook.Unprotect passw
ThisWorkbook.Sheets("xxxxxx").Visible = True
ThisWorkbook.Protect passw
End Sub
Private Sub Label220_Click()
On Error Resume Next
Dim i As Integer
For i = 40 To 195
Me.Controls("Label" & i).Caption = ""
Next i
For i = 212 To 216
Me.Controls("Label" & i).Caption = ""
Next i
For i = 241 To 339
Me.Controls("Label" & i).Caption = ""
Next i
End Sub
Private Sub Label23_Click()
Unload Me
End Sub
Private Sub TextBox3_Exit(ByVal cancel As MSForms.ReturnBoolean)
TextBox3.Text = Format(TextBox3.Text, "00:00")
End Sub
Private Sub TextBox20_Exit(ByVal cancel As MSForms.ReturnBoolean)
TextBox20.Text = Format(TextBox20.Text, "00:00")
End Sub
Private Sub TextBox21_Exit(ByVal cancel As MSForms.ReturnBoolean)
TextBox21.Text = Format(TextBox21.Text, "00:00")
If TextBox25.value <> "" Then
MsgBox "Sie können ML und ÜZ aus Vormonaten " & _
"nicht gleichzeitig auf den Folgemonat übertragen." & _
vbCrLf & "Ziehen Sie die ÜZ manuell von der ML ab und tragen" & vbCrLf & _
"Sie das Ergebnis ein.", vbExclamation + vbOKOnly, "Eingabefehler"
TextBox21.Text = ""
Else
End If
End Sub
Private Sub TextBox25_Exit(ByVal cancel As MSForms.ReturnBoolean)
On Error Resume Next
TextBox25.Text = Format(TextBox25.Text, "00:00")
If TextBox21.value <> "" Then
MsgBox "Sie können ML und ÜZ aus Vormonaten " & _
"nicht gleichzeitig auf den Folgemonat übertragen." & _
vbCrLf & "Ziehen Sie die ÜZ manuell von der ML ab und tragen" & vbCrLf & _
"Sie das Ergebnis ein.", vbExclamation + vbOKOnly, "Eingabefehler"
TextBox25.Text = ""
Else
End If
End Sub
Private Function GetTextBox6Value() As String
Dim iposit As Integer
Dim iHH As Integer
Dim iMM As Integer
Dim value As String
iposit = InStr(TextBox6.value, ":")
iHH = Val(Left(TextBox6.value, iposit - 1))
iMM = Val(Mid(TextBox6.value, iposit + 1))
value = iHH + IIf(iMM < 30, 0, 1)
GetTextBox6Value = Replace(Mid(Str(value), 2), ",", ":")
Exit Function
End Function
Private Sub userform_initialize()
TextBox6.Visible = False
TextBox24.Visible = False
End Sub
Private Sub UserForm_QueryClose(cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
cancel = True
End If
End Sub
Private Sub zurück()
Dim i As Integer
On Error Resume Next
For i = 1 To 30
Me.Controls("CommandButton" & i).Enabled = False
Next i
End Sub Dialog UserForm3Option Explicit
Private Sub Label13_Click()
On Error Resume Next
Application.ScreenUpdating = False
ThisWorkbook.Sheets("xxxxxx").Unprotect passw
Range("E6").Select
ActiveCell.value = TextBox1.value
ActiveCell.Offset(0, 1).value = TextBox2.value
ActiveCell.Offset(0, 2).value = TextBox3.value
ActiveCell.Offset(0, 3).value = TextBox4.value
ActiveCell.Offset(0, 4).value = TextBox5.value
ActiveCell.Offset(0, 5).value = TextBox6.value
ActiveCell.Offset(0, 6).value = TextBox7.value
ActiveCell.Offset(0, 7).value = TextBox8.value
ActiveCell.Offset(0, 8).value = TextBox9.value
ActiveCell.Offset(0, 9).value = TextBox10.value
ActiveCell.Offset(0, 10).value = TextBox11.value
ActiveCell.Offset(0, 11).value = TextBox12.value
Application.ScreenUpdating = True
ThisWorkbook.Sheets("xxxxxx").Protect passw
Unload Me
End Sub
Private Sub Label14_Click()
Unload Me
Range("A1").Select
End Sub Dialog userform1Option Explicit
Private Sub CoEnde_Click()
Unload Me
End Sub
Private Sub CheckBox1_Click()
On Error Resume Next
Dim DistAZ As String
If CheckBox1.value = True Then
DistAZ = "xxxxxx"
SaveSetting "xxxxxx", "xxxxxx", "xxxxxx", DistAZ
Else
DistAZ = ""
SaveSetting "xxxxxx", "xxxxxx", "xxxxxx", DistAZ
End If
End Sub
Private Sub Label22_Click()
Unload Me
End Sub
Private Sub userform_initialize()
On Error Resume Next
Dim level As String
Dim DistAZ As String
DistAZ = GetSetting("xxxxxx", "xxxxxx", "xxxxxx")
If GetSetting("xxxxxx", "xxxxxx", "xxxxxx") = "xxxxxx" Then CheckBox1.value = True
With TextBox1
.SetFocus
.SelStart = 0
.SelLength = 0
.Locked = True
End With
With TextBox2
.SetFocus
.SelStart = 0
.SelLength = 0
.Locked = True
End With
End Sub
Private Sub UserForm_QueryClose(cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
cancel = True
End If
End Sub Dialog UserForm4Private Sub Label4_Click()
Unload Me
End Sub
Modul basMenuesOption Explicit
Option Private Module
Public Const ComPuterName1 = "xxxxxx"
Public Const ComPuterName2 = "xxxxxx"
Public Const passw = "xxxxxx"
Sub HilfeAufrufen()
Application.EnableCancelKey = xlDisabled
userform1.Show
End Sub
Sub PlanEin()
Application.EnableCancelKey = xlDisabled
On Error Resume Next
userform2.Show
End Sub
Sub ZeitManuell()
Application.EnableCancelKey = xlDisabled
UserForm3.Show
End Sub
Sub groupTelefonieren()
Application.EnableCancelKey = xlDisabled
On Error Resume Next
UserForm4.Show
End Sub
Sub SeiteDrucken()
Application.Dialogs(xlDialogPrint).Show
End Sub
Sub Zurücksetzen()
Application.EnableCancelKey = xlDisabled
On Error Resume Next
ThisWorkbook.Sheets("xxxxxx").Range("F5:F8,F10:F17,F20:F22, K5:K5").ClearContents
ThisWorkbook.Sheets("xxxxxx").Range("F18").value = "0"
Dim DistAZ As String
Dim DistYear As String
Dim DistMap As String
Dim m As String
m = ""
DistMap = m
DistAZ = ""
DistYear = ""
DeleteSetting "xxxxxx", "xxxxxx", "xxxxxx"
DeleteSetting "xxxxxx", "xxxxxx", "xxxxxx"
DeleteSetting "xxxxxx", "xxxxxx", Environ("USERNAME")
DeleteSetting "xxxxxx", "xxxxxx", "xxxxxx"
DeleteSetting "xxxxxx", "xxxxxx", "xxxxxx"
Sheets("xxxxxx").CommandButton1.Visible = False
End Sub
Sub SpeichernUnter()
On Error Resume Next
Application.EnableCancelKey = xlDisabled
If ThisWorkbook.Sheets("xxxxxx").Range("NKürzel").value = 0 Then GoTo fehlerm:
Const Lw = "C:\"
Const Pfad = "ThisWorkbook.Path"
ActiveWorkbook.SaveAs ThisWorkbook.Sheets("xxxxxx").Range("K7").value
Exit Sub
fehlerm:
MsgBox "Sie haben kein Namenskürzel unter den " & vbCrLf & _
"persönlichen Daten angegeben. Sie können " & vbCrLf & _
"daher die Arbeitsmappe nicht unter einem " & vbCrLf & _
"anderen Namen speichern. Bitte geben Sie " & vbCrLf & _
"erst noch Ihre persönlichen Daten ein. ", vbOKOnly + vbInformation, "Sicherheitshinweis"
End Sub
Sub ScrollBar()
Application.EnableCancelKey = xlDisabled
On Error Resume Next
Application.ScreenUpdating = False
With ActiveWindow
.DisplayHorizontalScrollBar = Not .DisplayHorizontalScrollBar
.DisplayVerticalScrollBar = Not .DisplayVerticalScrollBar
End With
Application.ScreenUpdating = True
End Sub
Sub MRTCode()
Application.EnableCancelKey = xlDisabled
Dim Excelversion As Byte
If (Environ("COMPUTERNAME") = ComPuterName1 And GetSetting("xxxxxx", "xxxxxx", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Or _
(Environ("COMPUTERNAME") = ComPuterName2 And GetSetting("xxxxxx", "xxxxxx", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Then GoTo fehler
MsgBox "Sie haben nicht die notwendige Berechtigung " & vbCrLf & _
"zum Ausführen des Vorgangs. Dieses Makro ist " & vbCrLf & _
"ist dem Autor vorbehalten." & vbCrLf & vbCrLf & _
" Vorgang abgebrochen. ", vbExclamation + vbOKOnly, _
" *** Hinweis des Autors *** "
Exit Sub
fehler:
If Excelversion >= 10 Then
On Error GoTo xpfehler
End If
SendKeys ("%{F11}"), True
If Application.VBE.ActiveVBProject.Protection Then
Select Case Excelversion
Case "8"
SendKeys ("%xs" & GetSetting("xxxxxx", "xxxxxx", "xxxxxx") & "{ENTER}{ENTER}"), True
Case Else
SendKeys ("%xi" & GetSetting("xxxxxx", "xxxxxx", "xxxxxx") & "{ENTER}{ENTER}"), True
End Select
End If
Exit Sub
xpfehler:
MsgBox "Dieses Makro benötigt den direkten Zugriff auf VBA." & vbCrLf & vbCrLf & _
"Bitte aktivieren Sie im Menü ""Extras - Makro - Sicherheit... - Vertrauenswürdige Quellen"" " & _
"die Option ""Zugriff auf Visual Basic-Projekt vertrauen""" & vbCrLf & vbCrLf & _
"Bitte lesen Sie auch die Microsoft Sicherheitshinweise zu dieser Einstellung! (Hilfe)"
Exit Sub
End Sub
Modul basFunktionenOption Explicit
Option Private Module
Type PeriodStartStop
Start As Double
Stop_ As Double
End Type
Function Schaltjahr(Jahreszahl)
If (Jahreszahl Mod 4) = 0 And (Jahreszahl Mod 100) <> 0 Or ((Jahreszahl Mod 400) = 0) Then
Schaltjahr = True
Else
Schaltjahr = False
End If
End Function
Function Urlaub(Art As String, Url As Date) As Double
If Art = "U" Then
Urlaub = Url
Else
Urlaub = 0
End If
End Function
Function UEZM(Kennziffer As String, Arbeitszeit As Date, Schwelle As Date, Gutschrift As Date) As Double
If Kennziffer = 5 And Arbeitszeit > Schwelle Then
UEZM = Arbeitszeit - Schwelle
ElseIf Kennziffer = 6 And Arbeitszeit > Schwelle Then
UEZM = (Arbeitszeit - Schwelle) + ((Arbeitszeit - Schwelle) * 24 * Gutschrift) / 24
ElseIf Kennziffer = 9 And Arbeitszeit > Schwelle Then
UEZM = Arbeitszeit - Schwelle
ElseIf Kennziffer = 10 And Arbeitszeit > Schwelle Then
UEZM = (Arbeitszeit - Schwelle) + ((Arbeitszeit - Schwelle) * 24 * Gutschrift) / 24
Else
UEZM = 0
End If
End Function
Function lohnma(Kennziffer As String, Ist As Date) As Double
If Kennziffer = 1 Or Kennziffer = 3 Or Kennziffer = 4 Or Kennziffer = 7 _
Or Kennziffer = 8 Then lohnma = Ist
End Function
Function lohnnormal(Kennziffer As String, Ist As Date, Soll As Date) As Double
If Kennziffer = 1 And Ist >= Soll Then
lohnnormal = Soll
ElseIf Kennziffer = 1 And Ist < Soll Then
lohnnormal = Ist
ElseIf Kennziffer = 3 And Ist >= Soll Then
lohnnormal = Soll
ElseIf Kennziffer = 3 And Ist < Soll Then
lohnnormal = Ist
ElseIf Kennziffer = 4 And Ist >= Soll Then
lohnnormal = Soll
ElseIf Kennziffer = 4 And Ist < Soll Then
lohnnormal = Ist
ElseIf Kennziffer = 7 And Ist >= Soll Then
lohnnormal = Soll
ElseIf Kennziffer = 7 And Ist < Soll Then
lohnnormal = Ist
ElseIf Kennziffer = 8 And Ist >= Soll Then
lohnnormal = Soll
ElseIf Kennziffer = 8 And Ist < Soll Then
lohnnormal = Ist
ElseIf Kennziffer = 9 And Ist >= Soll Then
lohnnormal = Soll
ElseIf Kennziffer = 9 And Ist < Soll Then
lohnnormal = Ist
ElseIf Kennziffer = 10 And Ist >= Soll Then
lohnnormal = Soll
ElseIf Kennziffer = 10 And Ist < Soll Then
lohnnormal = Ist
Else
lohnnormal = 0
End If
End Function
Function lohnzeit(Kennziffer As String, Ist As Date, Soll As Date) As Double
If Kennziffer = 6 Or Kennziffer = 5 Then
lohnzeit = 0
ElseIf Kennziffer = 1 And Ist > Soll Then
lohnzeit = Ist - Soll
ElseIf Kennziffer = 2 And Ist > Soll Then
lohnzeit = Ist - Soll
Else
lohnzeit = 0
End If
End Function
Function fta(Art As String, SpalteZwei As String, SpalteG As Date, SpalteH As Date, _
SpalteAQ As Date, SpalteAS As Date, SpalteAU As Date) As Double 'Feiertag1
If Art = "M" Or Art = "U" Or Art = "K" Then
fta = 0
ElseIf SpalteZwei = "x" Then
If SpalteG <= SpalteH Then
fta = (SpalteH - SpalteG) - (SpalteAQ + SpalteAS + SpalteAU)
Else
fta = (1 - SpalteG) - (SpalteAQ + SpalteAS + SpalteAU)
End If
Else
fta = 0
End If
End Function
Function ftb(Art As String, SpalteDrei As String, SpalteH As Date, SpalteAR As Date, _
SpalteAT As Date, SpalteAV As Date) As Double 'Feiertag2
If Art = "M" Or Art = "U" Or Art = "K" Then
ftb = 0
ElseIf SpalteDrei = "x" Then
ftb = (SpalteH - 0) - (SpalteAR + SpalteAT + SpalteAV)
Else
ftb = 0
End If
End Function
Function sonntag(Art As String, datum As Date, BeginnArbeit As Date, EndeArbeit As Date, _
Ist As Date, PauseEinsTag As Date, PauseZweiTag As Date, PauseDreiTag As Date) As Double
If Art = "M" Or Art = "U" Or Art = "K" Then
sonntag = 0
ElseIf Weekday(datum, vbMonday) = 7 Then
If BeginnArbeit <= EndeArbeit Then
sonntag = Ist
Else
sonntag = (1 - BeginnArbeit) - (PauseEinsTag + PauseZweiTag + PauseDreiTag)
End If
Else
sonntag = 0
End If
End Function
Function PEins(BeginnArbeit As Date, EndeArbeit As Date, BeginnPausen As Date, _
EndePausen As Date) As Double
On Error Resume Next
If BeginnArbeit > EndeArbeit And BeginnPausen > EndePausen Then
PEins = 1 - BeginnPausen
Else
PEins = 0
End If
End Function
Function PZwei(BeginnArbeit As Date, EndeArbeit As Date, EndePausen As Date, _
BeginnPausen As Date) As Double
If BeginnArbeit > EndeArbeit And EndePausen > EndeArbeit Then
PZwei = EndePausen - BeginnPausen
Else
PZwei = 0
End If
End Function
Function PDrei(BeginnArbeit As Date, EndeArbeit As Date, BeginnPausen As Date, _
EndePausen As Date) As Double
If BeginnArbeit < EndeArbeit And BeginnPausen < EndePausen Then
PDrei = EndePausen - BeginnPausen
Else
PDrei = 0
End If
End Function
Function PVier(BeginnArbeit As Date, EndeArbeit As Date, BeginnPausen As Date, _
EndePausen As Date) As Double
If BeginnArbeit > EndeArbeit And BeginnPausen > EndePausen Then
PVier = EndePausen - 0
Else
PVier = 0
End If
End Function
Function PFünf(BeginnArbeit As Date, EndeArbeit As Date, BeginnPausen As Date, _
EndePausen As Date) As Double
If BeginnArbeit > EndeArbeit And BeginnPausen < EndePausen Then
PFünf = EndePausen - BeginnPausen
Else
PFünf = 0
End If
End Function
Function PSechs(BeginnArbeit As Date, EndeArbeit As Date, BeginnPausen As Date, _
EndePausen As Date) As Double
If BeginnArbeit < BeginnPausen And EndeArbeit < EndePausen Then
PSechs = EndePausen - BeginnPausen
Else
PSechs = 0
End If
End Function
Function IstZeit(Art As String, BeginnArbeit As Date, EndeArbeit As Date, PauseGesamt As Date) As Double
If Art = "M" Or Art = "R" Then
IstZeit = 0
ElseIf BeginnArbeit <= EndeArbeit Then
IstZeit = (EndeArbeit - BeginnArbeit) - PauseGesamt
Else
IstZeit = (1 - BeginnArbeit + EndeArbeit) - PauseGesamt
End If
End Function
Function UEMZeit(Art As String, Ist As Date, Soll As Date) As Double
If Art = "M" Or Art = "R" Or Art = "K" Or Art = "U" Then
UEMZeit = 0
Else
UEMZeit = (Ist - Soll)
End If
End Function
Function UETM(Art As String, BeginnArbeit As Date, EndeArbeit As Date, Pause As Date) As Double
If Art = "M" And BeginnArbeit < EndeArbeit Then
UETM = EndeArbeit - BeginnArbeit - Pause
ElseIf Art = "M" And BeginnArbeit > EndeArbeit Then
UETM = (1 - BeginnArbeit) + EndeArbeit - Pause
Else
UETM = 0
End If
End Function
Function ZeitGut(Kennziffer As String, Ist As Date, Soll As Date, FaktorGutschrift As Date) As Double
If Kennziffer = 5 Or Kennziffer = 6 Then
ZeitGut = 0
ElseIf Kennziffer <> 3 Then
ZeitGut = 0
ElseIf Ist > Soll Then
ZeitGut = ((Ist - Soll) * 24) * FaktorGutschrift / 24
Else
ZeitGut = 0
End If
End Function
Function FZK(Kennziffer As String, Ist As Date, Soll As Date, SpalteX As Date) As Double
If Kennziffer = 5 Or Kennziffer = 6 Then
FZK = 0
ElseIf Kennziffer = 3 And Ist > Soll Then
FZK = (Ist - Soll) + SpalteX
ElseIf Kennziffer = 7 And Ist > Soll Then
FZK = Ist - Soll
Else
FZK = 0
End If
End Function
Function SPause(BeginnPause As Date, EndePause As Date) As Double
If BeginnPause <= EndePause Then
SPause = EndePause - BeginnPause
Else
SPause = (1 - BeginnPause) + EndePause
End If
End Function
Function samstags(Art As String, samstag As Date, BeginnArbeit As Date, EndeArbeit As Date, _
BeginnPauseEins As Date, EndePauseEins As Date, BeginnPauseZwei As Date, EndePauseZwei As Date, _
BeginnPauseDrei As Date, EndePauseDrei As Date, _
Optional ShiftStart As Date, _
Optional ShiftEnd As Date) As Double
On Error Resume Next
Dim i As Long
Dim j As Long
Dim Arbeit As Double
Dim PauseEins As Double
Dim PauseZwei As Double
Dim PauseDrei As Double
Dim Shift() As PeriodStartStop
Dim WorkedArbeit() As PeriodStartStop
Dim WorkedPauseEins() As PeriodStartStop
Dim WorkedPauseZwei() As PeriodStartStop
Dim WorkedPauseDrei() As PeriodStartStop
Rem Kommen und Gehen
GetPeriods CDbl(BeginnArbeit), CDbl(EndeArbeit), WorkedArbeit()
GetPeriods CDbl(ShiftStart), CDbl(ShiftEnd), Shift()
Arbeit = 0
For i = 0 To Ubound(WorkedArbeit())
For j = 0 To Ubound(Shift())
Arbeit = Arbeit + GetOverlap(WorkedArbeit(i), Shift(j))
Next j
Next i
Rem Gehen und Kommen Pause 1
GetPeriods CDbl(BeginnPauseEins), CDbl(EndePauseEins), WorkedPauseEins()
GetPeriods CDbl(ShiftStart), CDbl(ShiftEnd), Shift()
PauseEins = 0
For i = 0 To Ubound(WorkedPauseEins())
For j = 0 To Ubound(Shift())
PauseEins = PauseEins + GetOverlap(WorkedPauseEins(i), Shift(j))
Next j
Next i
Rem Gehen und Kommen Pause 2
GetPeriods CDbl(BeginnPauseZwei), CDbl(EndePauseZwei), WorkedPauseZwei()
GetPeriods CDbl(ShiftStart), CDbl(ShiftEnd), Shift()
PauseZwei = 0
For i = 0 To Ubound(WorkedPauseZwei())
For j = 0 To Ubound(Shift())
PauseZwei = PauseZwei + GetOverlap(WorkedPauseZwei(i), Shift(j))
Next j
Next i
Rem Gehen und Kommen Pause 3
GetPeriods CDbl(BeginnPauseDrei), CDbl(EndePauseDrei), WorkedPauseDrei()
GetPeriods CDbl(ShiftStart), CDbl(ShiftEnd), Shift()
PauseDrei = 0
For i = 0 To Ubound(WorkedPauseDrei())
For j = 0 To Ubound(Shift())
PauseDrei = PauseDrei + GetOverlap(WorkedPauseDrei(i), Shift(j))
Next j
Next i
If Art = "M" Or Art = "U" Or Art = "K" Then
samstags = 0
ElseIf Weekday(samstag, vbMonday) = 6 Then
samstags = (Round(Arbeit * 24, 5) - (Round(PauseEins * 24, 5) + Round(PauseZwei * 24, 5) _
+ Round(PauseDrei * 24, 5))) / 24
Else
samstags = 0
End If
End Function
Function ZeitR(Art As String, BeginnArbeit As Date, EndeArbeit As Date, BeginnPauseEins As Date, _
EndePauseEins As Date, BeginnPauseZwei As Date, EndePauseZwei As Date, BeginnPauseDrei As Date, _
EndePauseDrei As Date, _
Optional ShiftStart As Date, _
Optional ShiftEnd As Date) As Double
On Error Resume Next
Dim i As Long
Dim j As Long
Dim Arbeit As Double
Dim PauseEins As Double
Dim PauseZwei As Double
Dim PauseDrei As Double
Dim Shift() As PeriodStartStop
Dim WorkedArbeit() As PeriodStartStop
Dim WorkedPauseEins() As PeriodStartStop
Dim WorkedPauseZwei() As PeriodStartStop
Dim WorkedPauseDrei() As PeriodStartStop
Rem Kommen und Gehen
GetPeriods CDbl(BeginnArbeit), CDbl(EndeArbeit), WorkedArbeit()
GetPeriods CDbl(ShiftStart), CDbl(ShiftEnd), Shift()
Arbeit = 0
For i = 0 To Ubound(WorkedArbeit())
For j = 0 To Ubound(Shift())
Arbeit = Arbeit + GetOverlap(WorkedArbeit(i), Shift(j))
Next j
Next i
Rem Gehen und Kommen Pause 1
GetPeriods CDbl(BeginnPauseEins), CDbl(EndePauseEins), WorkedPauseEins()
GetPeriods CDbl(ShiftStart), CDbl(ShiftEnd), Shift()
PauseEins = 0
For i = 0 To Ubound(WorkedPauseEins())
For j = 0 To Ubound(Shift())
PauseEins = PauseEins + GetOverlap(WorkedPauseEins(i), Shift(j))
Next j
Next i
Rem Gehen und Kommen Pause 2
GetPeriods CDbl(BeginnPauseZwei), CDbl(EndePauseZwei), WorkedPauseZwei()
GetPeriods CDbl(ShiftStart), CDbl(ShiftEnd), Shift()
PauseZwei = 0
For i = 0 To Ubound(WorkedPauseZwei())
For j = 0 To Ubound(Shift())
PauseZwei = PauseZwei + GetOverlap(WorkedPauseZwei(i), Shift(j))
Next j
Next i
Rem Gehen und Kommen Pause 3
GetPeriods CDbl(BeginnPauseDrei), CDbl(EndePauseDrei), WorkedPauseDrei()
GetPeriods CDbl(ShiftStart), CDbl(ShiftEnd), Shift()
PauseDrei = 0
For i = 0 To Ubound(WorkedPauseDrei())
For j = 0 To Ubound(Shift())
PauseDrei = PauseDrei + GetOverlap(WorkedPauseDrei(i), Shift(j))
Next j
Next i
If Art = "M" Or Art = "U" Or Art = "K" Then
ZeitR = 0
Else
ZeitR = (Round(Arbeit * 24, 5) - (Round(PauseEins * 24, 5) + Round(PauseZwei * 24, 5) _
+ Round(PauseDrei * 24, 5))) / 24
End If
End Function
Private Sub GetPeriods(ByVal t1 As Double, ByVal t2 As Double, _
Period() As PeriodStartStop)
t1 = t1 - Int(t1)
t2 = t2 - Int(t2)
If t1 <= t2 Then
Redim Period(0 To 0)
Period(0).Start = t1
Period(0).Stop_ = t2
Else
Redim Period(0 To 1)
Period(0).Start = t1
Period(0).Stop_ = 1
Period(1).Start = 0
Period(1).Stop_ = t2
End If
End Sub
Private Function GetOverlap(Period1 As PeriodStartStop, _
Period2 As PeriodStartStop) As Double
Dim t1 As Double
Dim t2 As Double
If Period1.Start >= Period2.Start Then
t1 = Period1.Start
Else
t1 = Period2.Start
End If
If Period1.Stop_ <= Period2.Stop_ Then
t2 = Period1.Stop_
Else
t2 = Period2.Stop_
End If
t2 = t2 - t1
If t2 < 0 Then t2 = 0
GetOverlap = t2
End Function
Modul basMonateOption Explicit
Option Private Module
Sub AlleMonateEin()
Application.EnableCancelKey = xlDisabled
On Error Resume Next
If (Environ("COMPUTERNAME") = ComPuterName1 And GetSetting("xxxxxx", "xxxxxx", "DistVariPrivate4") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Or _
(Environ("COMPUTERNAME") = ComPuterName2 And GetSetting("xxxxxx", "xxxxxx", "DistVariPrivate4") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Then GoTo Anfang
MsgBox "Sie haben nicht die notwendige Berechtigung " & vbCrLf & _
"zum Ausführen des Vorgangs. Dieses Makro ist " & vbCrLf & _
"ist dem Autor vorbehalten." & vbCrLf & vbCrLf & _
" Vorgang abgebrochen. ", vbExclamation + vbOKOnly, _
" *** Hinweis des Autors *** "
Exit Sub
Anfang:
Application.ScreenUpdating = False
ActiveSheet.Unprotect passw
Range("E8").FormulaR1C1 = ""
Range("E8").FormulaR1C1 = ""
Rows("8:745").EntireRow.Hidden = False
ActiveWindow.SmallScroll Down:=-1234
Rows("746:1048576").EntireRow.Hidden = True
ActiveWindow.SmallScroll Down:=-1234
ActiveSheet.Protect passw
Application.ScreenUpdating = True
End Sub
Sub JanuarEin()
On Error Resume Next
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
ActiveSheet.Unprotect passw
Range("E8").FormulaR1C1 = "=DATE(datum1,1,1)"
Rows("12:744").EntireRow.Hidden = True
Rows("12:73").EntireRow.Hidden = False
ActiveWindow.SmallScroll Down:=-1234
ActiveSheet.Protect passw
Application.ScreenUpdating = True
End Sub
Sub FebruarEin()
On Error Resume Next
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
ActiveSheet.Unprotect passw
Range("E8").FormulaR1C1 = "=DATE(datum1,2,1)"
Rows("12:744").EntireRow.Hidden = True
Rows("74:131").EntireRow.Hidden = False
ActiveWindow.LargeScroll Down:=-1234
ActiveSheet.Protect passw
Application.ScreenUpdating = True
End Sub
Sub MärzEin()
On Error Resume Next
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
ActiveSheet.Unprotect passw
Range("E8").FormulaR1C1 = "=DATE(datum1,3,1)"
Rows("12:744").EntireRow.Hidden = True
Rows("132:193").EntireRow.Hidden = False
ActiveWindow.LargeScroll Down:=-1234
ActiveSheet.Protect passw
Application.ScreenUpdating = True
End Sub
Sub AprilEin()
On Error Resume Next
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
ActiveSheet.Unprotect passw
Range("E8").FormulaR1C1 = "=DATE(datum1,4,1)"
Rows("12:744").EntireRow.Hidden = True
Rows("194:253").EntireRow.Hidden = False
ActiveWindow.LargeScroll Down:=-1234
ActiveSheet.Protect passw
Application.ScreenUpdating = True
End Sub
Sub MaiEin()
On Error Resume Next
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
ActiveSheet.Unprotect passw
Range("E8").FormulaR1C1 = "=DATE(datum1,5,1)"
Rows("12:744").EntireRow.Hidden = True
Rows("254:315").EntireRow.Hidden = False
ActiveWindow.LargeScroll Down:=-1234
ActiveSheet.Protect passw
Application.ScreenUpdating = True
End Sub
Sub JuniEin()
On Error Resume Next
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
ActiveSheet.Unprotect passw
Range("E8").FormulaR1C1 = "=DATE(datum1,6,1)"
Rows("12:744").EntireRow.Hidden = True
Rows("316:375").EntireRow.Hidden = False
ActiveWindow.LargeScroll Down:=-1234
ActiveSheet.Protect passw
Application.ScreenUpdating = True
End Sub
Sub JuliEin()
On Error Resume Next
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
ActiveSheet.Unprotect passw
Range("E8").FormulaR1C1 = "=DATE(datum1,7,1)"
Rows("12:744").EntireRow.Hidden = True
Rows("376:437").EntireRow.Hidden = False
ActiveWindow.LargeScroll Down:=-1234
ActiveSheet.Protect passw
Application.ScreenUpdating = True
End Sub
Sub AugustEin()
On Error Resume Next
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
ActiveSheet.Unprotect passw
Range("E8").FormulaR1C1 = "=DATE(datum1,8,1)"
Rows("12:744").EntireRow.Hidden = True
Rows("438:499").EntireRow.Hidden = False
ActiveWindow.LargeScroll Down:=-1234
ActiveSheet.Protect passw
Application.ScreenUpdating = True
End Sub
Sub SeptemberEin()
On Error Resume Next
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
ActiveSheet.Unprotect passw
Range("E8").FormulaR1C1 = "=DATE(datum1,9,1)"
Rows("12:744").EntireRow.Hidden = True
Rows("500:559").EntireRow.Hidden = False
ActiveWindow.LargeScroll Down:=-1234
ActiveSheet.Protect passw
Application.ScreenUpdating = True
End Sub
Sub OktoberEin()
On Error Resume Next
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
ActiveSheet.Unprotect passw
Range("E8").FormulaR1C1 = "=DATE(datum1,10,1)"
Rows("12:744").EntireRow.Hidden = True
Rows("560:621").EntireRow.Hidden = False
ActiveWindow.LargeScroll Down:=-1234
ActiveSheet.Protect passw
Application.ScreenUpdating = True
End Sub
Sub NovemberEin()
On Error Resume Next
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
ActiveSheet.Unprotect passw
Range("E8").FormulaR1C1 = "=DATE(datum1,11,1)"
Rows("12:744").EntireRow.Hidden = True
Rows("622:681").EntireRow.Hidden = False
ActiveWindow.LargeScroll Down:=-1234
ActiveSheet.Protect passw
Application.ScreenUpdating = True
End Sub
Sub DezemberEin()
On Error Resume Next
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
ActiveSheet.Unprotect passw
Range("E8").FormulaR1C1 = "=DATE(datum1,12,1)"
Rows("12:744").EntireRow.Hidden = True
Rows("682:743").EntireRow.Hidden = False
ActiveWindow.LargeScroll Down:=-1234
ActiveSheet.Protect passw
Application.ScreenUpdating = True
End Sub
Modul basWochenendeOption Explicit
Option Private Module
Private Sub Week_end()
Application.EnableCancelKey = xlDisabled
Dim cell As Object
On Error Resume Next
Dim Zeile As Range
For Each cell In Worksheets("xxxxxx").Range("B13:B743")
If Weekday(cell, vbMonday) = 7 Then
cell.Font.ColorIndex = 3
ElseIf Weekday(cell, vbMonday) = 6 Then
cell.Font.ColorIndex = 5
Else
cell.Font.ColorIndex = 0
End If
Next cell
End Sub
Private Sub Week_end2()
Application.EnableCancelKey = xlDisabled
Dim cell As Object
On Error Resume Next
Dim Zeile As Range
For Each cell In Worksheets("xxxxxx").Range("AB13:AB743")
If Weekday(cell, vbMonday) = 7 Then
cell.Font.ColorIndex = 3
ElseIf Weekday(cell, vbMonday) = 6 Then
cell.Font.ColorIndex = 5
Else
cell.Font.ColorIndex = 0
End If
Next cell
End Sub
Sub Aendern()
Application.EnableCancelKey = xlDisabled
On Error Resume Next
Application.ScreenUpdating = False
Sheets("xxxxxx").Unprotect passw
Week_end
Week_day
Week_frei
Week_end2
Week_day2
Sheets("xxxxxx").Protect passw
Application.ScreenUpdating = True
End Sub
Private Sub Week_day()
Application.EnableCancelKey = xlDisabled
Dim cell As Object
On Error Resume Next
Dim Zeile As Range
For Each cell In Worksheets("xxxxxx").Range("B13:B743")
If cell.value = Sheets("xxxxxx").Range("A1").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A2").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A3").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A4").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A5").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A6").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A7").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A8").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A9").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A10").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A11").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A12").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A13").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A14").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A15").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A16").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A17").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A18").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A19").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A20").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A21").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A22").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A23").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A24").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A25").value Then
cell.Font.ColorIndex = 3
Else
End If
Next cell
End Sub
Private Sub Week_day2()
Application.EnableCancelKey = xlDisabled
Dim cell As Object
On Error Resume Next
Dim Zeile As Range
For Each cell In Worksheets("xxxxxx").Range("AB13:AB743")
If cell.value = Sheets("xxxxxx").Range("A1").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A2").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A3").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A4").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A5").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A6").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A7").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A8").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A9").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A10").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A11").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A12").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A13").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A14").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A15").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A16").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A17").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A18").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A19").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A20").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A21").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A22").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A23").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A24").value Then
cell.Font.ColorIndex = 3
ElseIf cell.value = Sheets("xxxxxx").Range("A25").value Then
cell.Font.ColorIndex = 3
Else
End If
Next cell
End Sub
Private Sub Week_frei()
Application.EnableCancelKey = xlDisabled
Dim cell As Object
On Error Resume Next
Dim Zeile As Range
For Each cell In Worksheets("xxxxxx").Range("B13:B743")
If cell.value = Sheets("xxxxxx").Range("A1").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A2").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A3").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A4").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A5").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A6").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A7").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A8").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A9").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A10").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A11").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A12").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A13").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A14").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A15").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A16").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A17").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A18").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A19").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A20").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A21").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A22").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A23").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A24").value Then
cell.Offset(0, 21).value = "F"
ElseIf cell.value = Sheets("xxxxxx").Range("A25").value Then
cell.Offset(0, 21).value = "F"
Else
cell.Offset(0, 21).value = ""
End If
Next cell
End Sub Modul basTabellenOption Explicit
Option Private Module
Sub Aufräumen()
On Error Resume Next
Application.EnableCancelKey = xlDisabled
Application.CommandBars.FindControl(ID:=106).Execute
End Sub
Sub Säubern1()
On Error Resume Next
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
ThisWorkbook.Sheets("xxxxxx").Range("C12:E743,F12:I743,J12:K743,M12:N743,P12:Q743,T12:T743").ClearContents
Application.ScreenUpdating = True
End Sub
Sub EinstellEin()
On Error Resume Next
Application.EnableCancelKey = xlDisabled
ThisWorkbook.Sheets("xxxxxx").Activate
ActiveWindow.LargeScroll Down:=-1234
End Sub
Private Sub Feiertag()
Application.EnableCancelKey = xlDisabled
ThisWorkbook.Sheets("xxxxxx").Activate
End Sub
Sub BlattArbeit()
On Error Resume Next
Application.EnableCancelKey = xlDisabled
If Sheets("xxxxxx").Visible = xlVeryHidden Then GoTo fehler
Sheets("xxxxxx").Activate
Exit Sub
fehler:
MsgBox "Bitte vervollständigen Sie erst Ihre " & vbCrLf & _
"persönlichen Daten. Ohne diese Angaben " & vbCrLf & _
"können Sie die Arbeitsmappe nicht nutzen.", vbOKOnly + vbExclamation, "Warnung"
End Sub
Sub PlanAus()
On Error Resume Next
Application.EnableCancelKey = xlDisabled
If Sheets("xxxxxx").Visible = xlVeryHidden Then GoTo fehler
Sheets("xxxxxx").Activate
Dim i As Integer
For i = 1 To 13
Application.CommandBars("Arbeitszeit").Controls(i).Enabled = False
Next i
Exit Sub
fehler:
MsgBox "Bitte vervollständigen Sie erst Ihre " & vbCrLf & _
"persönlichen Daten. Ohne diese Angaben " & vbCrLf & _
"können Sie die Arbeitsmappe nicht nutzen.", vbOKOnly + vbExclamation, "Warnung"
End Sub
Private Sub Arbeitszeiten()
Application.EnableCancelKey = xlDisabled
On Error Resume Next
Application.ScreenUpdating = False
Dim i As Integer
For i = 1 To 13
Application.CommandBars("Arbeitszeit").Controls(i).Enabled = True
Next i
ThisWorkbook.Sheets("xxxxxx").Unprotect passw
ActiveSheet.ScrollArea = ""
Columns("A:AA").EntireColumn.Hidden = False
Range("A1").Select
Columns("W:W").EntireColumn.Hidden = True
Columns("AB:AY").EntireColumn.Hidden = True
ActiveWindow.SmallScroll ToRight:=-35
Range("E8").FormulaR1C1 = "=DATE(datum1,1,1)"
ActiveWindow.FreezePanes = True
ThisWorkbook.Sheets("xxxxxx").Protect passw
Application.ScreenUpdating = True
End Sub
Sub Zuschläge()
Application.EnableCancelKey = xlDisabled
On Error Resume Next
Application.ScreenUpdating = False
Dim i As Integer
For i = 1 To 13
Application.CommandBars("Arbeitszeit").Controls(i).Enabled = True
Next i
ThisWorkbook.Sheets("xxxxxx").Unprotect passw
Columns("A:AY").EntireColumn.Hidden = False
Columns("A:AA").EntireColumn.Hidden = True
Columns("AS:AX").EntireColumn.Hidden = True
ActiveWindow.SmallScroll ToRight:=25
Range("E8").FormulaR1C1 = "=DATE(datum1,1,1)"
ActiveWindow.SmallScroll Down:=-1000
Range("AB7").Select
ThisWorkbook.Sheets("xxxxxx").Protect passw
ActiveWindow.SmallScroll ToRight:=-25
ActiveWindow.SmallScroll Down:=-3768
Application.ScreenUpdating = True
End Sub
Sub box()
Application.EnableCancelKey = xlDisabled
On Error Resume Next
Dim Excelversion As Byte
If (Environ("COMPUTERNAME") = ComPuterName1 And GetSetting("xxxxxx", "xxxxxx", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxx")) Or _
(Environ("COMPUTERNAME") = ComPuterName2 And GetSetting("xxxxxx", "AZTab01", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Then GoTo fehler
MsgBox "Sie haben nicht die notwendige Berechtigung " & vbCrLf & _
"zum Ausführen des Vorgangs. Dieses Makro ist " & vbCrLf & _
"ist dem Autor vorbehalten." & vbCrLf & vbCrLf & _
" Vorgang abgebrochen. ", vbExclamation + vbOKOnly, _
" *** Hinweis des Autors *** "
Exit Sub
fehler:
Dim blatt As Object
Sheets("xxxxxx").Activate
If ThisWorkbook.Sheets("xxxxxx").Columns("AB:AY").EntireColumn.Hidden = True Then
Application.ScreenUpdating = False
ActiveWindow.DisplayWorkbookTabs = True
Rem Application.Calculation = xlManual
For Each blatt In ActiveWorkbook.Sheets
blatt.Activate
blatt.Unprotect passw
blatt.ScrollArea = ""
ActiveWindow.DisplayHeadings = True
Next blatt
Sheets("xxxxxx").Activate
Columns("A:AY").EntireColumn.Hidden = False
Columns("W:W").EntireColumn.Hidden = True
Rows("8:745").EntireRow.Hidden = False
ActiveWindow.SmallScroll Down:=-1234
With ActiveWindow
.DisplayHorizontalScrollBar = True
.DisplayVerticalScrollBar = True
End With
Application.ScreenUpdating = True
Else
Application.ScreenUpdating = False
Application.Calculation = xlAutomatic
Sheets("xxxxxx").ScrollArea = "A1:C27"
Sheets("xxxxxx").ScrollArea = "A1:W22"
Sheets("xxxxxx").ScrollArea = "A1:Y900"
Sheets("xxxxxx").ScrollArea = "A1:U80"
Sheets("xxxxxx").Activate
ThisWorkbook.Sheets("xxxxxx").Columns("AB:AY").EntireColumn.Hidden = True
Range("A12").Select
Range("E8").FormulaR1C1 = "=DATE(datum1,1,1)"
Rows("12:745").EntireRow.Hidden = True
Rows("8:73").EntireRow.Hidden = False
Rows("745:745").EntireRow.Hidden = False
ActiveWindow.SmallScroll Down:=-1234
ActiveWindow.SmallScroll ToRight:=-236
For Each blatt In ActiveWorkbook.Sheets
blatt.Activate
blatt.Protect passw
ActiveWindow.DisplayHeadings = False
Next blatt
ActiveWindow.DisplayWorkbookTabs = False
Sheets("xxxxxx").Activate
With ActiveWindow
.DisplayHorizontalScrollBar = False
.DisplayVerticalScrollBar = False
End With
Application.ScreenUpdating = True
End If
End Sub
Modul basSchutzOption Explicit
Option Private Module
Sub BlattSchutzAus()
On Error Resume Next
Application.EnableCancelKey = xlDisabled
If ActiveSheet.ProtectContents = False Then Exit Sub
If (Environ("COMPUTERNAME") = ComPuterName1 And GetSetting("xxxxxx", "xxxxx", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Or _
(Environ("COMPUTERNAME") = ComPuterName2 And GetSetting("xxxxxx", "xxxxxx", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxx")) Then
Application.ScreenUpdating = False
Dim blatt As Object
For Each blatt In ActiveWorkbook.Sheets
blatt.Unprotect passw
blatt.ScrollArea = ""
Next blatt
Application.ScreenUpdating = True
Else
MsgBox "Sie haben nicht die notwendige Berechtigung " & vbCrLf & _
"zum Ausführen des Vorgangs. Dieses Makro ist " & vbCrLf & _
"ist dem Autor vorbehalten." & vbCrLf & vbCrLf & _
" Vorgang abgebrochen. ", vbExclamation + vbOKOnly, " *** Hinweis des Autors *** "
End If
End Sub
Sub BlattSchutzEin()
On Error Resume Next
Application.EnableCancelKey = xlDisabled
If ActiveSheet.ProtectContents = True Then Exit Sub
If (Environ("COMPUTERNAME") = ComPuterName1 And GetSetting("xxxxxx", "xxxxxx", "xxxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Or _
(Environ("COMPUTERNAME") = ComPuterName2 And GetSetting("xxxxxx", "xxxxxx", "xxxxxx") _
= GetSetting("xxxxxx", "xxxxxx", "xxxxxx")) Then
Application.ScreenUpdating = False
Sheets("xxxxxx").ScrollArea = "A1:C27"
Sheets("xxxxxx").ScrollArea = "A1:W21"
Sheets("xxxxxx").ScrollArea = "A1:AF1229"
Dim blatt As Object
For Each blatt In ActiveWorkbook.Sheets
With blatt
.Protect passw
.EnableSelection = xlUnlockedCells
End With
Next blatt
Application.ScreenUpdating = True
Else
MsgBox "Sie haben nicht die notwendige Berechtigung " & vbCrLf & _
"zum Ausführen des Vorgangs. Dieses Makro ist " & vbCrLf & _
"ist dem Autor vorbehalten." & vbCrLf & vbCrLf & _
" Vorgang abgebrochen. ", vbExclamation + vbOKOnly, _
" *** Hinweis des Autors *** "
End If
End Sub
Modul basLeistenOption Explicit
Option Private Module
Sub AZTab_FullBar34()
Dim symb As CommandBar
Dim AA As Object
Set symb = Application.CommandBars.Add("Arbeitszeit", Position:=msoBarTop, Temporary:=True)
With symb
.Left = 0
.Visible = True
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonCaption
.Caption = "Jan"
.BeginGroup = True
.OnAction = "JanuarEin"
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonCaption
.Caption = "Feb"
.OnAction = "FebruarEin"
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonCaption
.Caption = "März"
.OnAction = "MärzEin"
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonCaption
.Caption = "Apr"
.OnAction = "AprilEin"
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonCaption
.Caption = "Mai"
.OnAction = "MaiEin"
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonCaption
.Caption = "Juni"
.OnAction = "JuniEin"
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonCaption
.Caption = "Juli"
.OnAction = "JuliEin"
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonCaption
.Caption = "Aug"
.OnAction = "AugustEin"
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonCaption
.Caption = "Sep"
.OnAction = "SeptemberEin"
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonCaption
.Caption = "Okt"
.OnAction = "OktoberEin"
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonCaption
.Caption = "Nov"
.OnAction = "NovemberEin"
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonCaption
.Caption = "Dez"
.OnAction = "DezemberEin"
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 47
.TooltipText = "Zeitangaben löschen"
.BeginGroup = True
.OnAction = "Säubern1"
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 370
.TooltipText = "Arbeitszeiten verwalten (Blatt ""Zeitnachweis"" aktivieren)"
.OnAction = "BlattArbeit"
.BeginGroup = False
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 125
.TooltipText = "Arbeitszeiten eingeben (Tabellenteil 1)"
.OnAction = "Arbeitszeiten"
.BeginGroup = False
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 734
.TooltipText = "Zuschläge anzeigen"
.OnAction = "Zuschläge"
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 17
.TooltipText = "Statistik aufrufen"
.OnAction = "PlanAus"
.BeginGroup = False
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 126
.TooltipText = "Monatssoll errechnen"
.OnAction = "PlanEin"
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 449
.TooltipText = "Monatssoll manuell eingeben"
.OnAction = "ZeitManuell"
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 1665
.TooltipText = "Persönliche Daten eingeben"
.OnAction = "EinstellEin"
.BeginGroup = True
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 964
.TooltipText = "Persönliche Daten löschen"
.OnAction = "Zurücksetzen"
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 33
.TooltipText = "Feiertagsliste aktualisieren"
.OnAction = "Feiertag"
.BeginGroup = True
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 271
.TooltipText = "Arbeitsmappe speichern"
.OnAction = "SpeichernUnter"
.BeginGroup = True
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 237
.TooltipText = "Bildlaufleisten ein- bzw. ausblenden"
.OnAction = "ScrollBar"
.BeginGroup = True
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 4
.TooltipText = "Aktuelle Ansicht drucken"
.OnAction = "SeitDrucken"
.BeginGroup = True
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 345
.TooltipText = "Impressum"
.OnAction = "HilfeAufrufen"
.BeginGroup = True
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 487
.TooltipText = "Vesionsinformation"
.OnAction = "groupTelefonieren"
End With
Set AA = Application.CommandBars("Arbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 1088
.TooltipText = "Arbeitsmappe schließen (Änderungen werden gespeichert)"
.OnAction = "Aufräumen"
.BeginGroup = True
End With
End Sub
Sub ArbeitTest()
Dim symb As CommandBar
Dim AA As Object
On Error Resume Next
Set symb = Application.CommandBars.Add("MeineArbeitszeit", Position:=msoBarTop, Temporary:=True)
With symb
.Left = 0
.Visible = True
End With
Set AA = Application.CommandBars("MeineArbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 505
.OnAction = "BlattSchutzAus"
.BeginGroup = False
End With
Set AA = Application.CommandBars("MeineArbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 225
.OnAction = "BlattSchutzEin"
.BeginGroup = False
End With
Set AA = Application.CommandBars("MeineArbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 611
.OnAction = "MRTCode"
.BeginGroup = False
End With
Set AA = Application.CommandBars("MeineArbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 263
.OnAction = "box"
.BeginGroup = False
End With
Set AA = Application.CommandBars("MeineArbeitszeit").Controls.Add(Type:=msoControlButton)
With AA
.Style = msoButtonIcon
.FaceId = 629
.OnAction = "AlleMonateEin"
.BeginGroup = False
End With
End Sub
Code eingefügt mit VBA in HTML 1.2 ( Hilfe zum Programm)