AW: Zeig den Code oder die Mappe (owT)
21.12.2022 04:54:21
Rolf
Ok, hier also die gewünschten Makros, obwohl ich fürchte, dass sie nicht viel weiter helfen.
a) Workbook_Ereignis: Das eigentliche Makro (WS_DoubleClick2) soll für eine Vielzahl von Sheets aufgerufen werden. Es ist in einer separaten Datei (pepMAKROS.xlsm) abgelegt.
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
'*** Ausschluss ***************************
If Not ActiveSheet.Name = "Master" And Not Left(ActiveSheet.Name, 2) = "KW" Then Exit Sub
Dim ws As String, HOME As String, ENDE As String
Dim z As Long
Dim sp As Integer
Dim persBer As Range, zeitBer As Range
ws = ActiveSheet.Name
HOME = ActiveSheet.Range("HOME").Address
sp = Range(HOME).Column
Application.Run "pepMAKROS.xlsm!BlattschutzNein"
z = Cells.SpecialCells(xlCellTypeLastCell).Row
Application.Run "pepMAKROS.xlsm!BlattschutzJa"
ENDE = Sheets(ws).Cells(z, sp).End(xlUp).Address
BEREICH1:
Set persBer = Range(HOME, Range(ENDE).Offset(-3, 0)).Offset(1, 1)
Set zeitBer = Range(HOME, Range(ENDE).Offset(-3, 29)).Offset(1, 3)
If Intersect(Target, persBer) Is Nothing Then
GoTo BEREICH2
Else
Application.Run "pepMAKROS.xlsm!WS_DoubleClick1"
End If
BEREICH2:
If Intersect(Target, zeitBer) Is Nothing Then
Exit Sub
Else
Application.Run "pepMAKROS.xlsm!WS_DoubleClick2"
End If
End Sub
b) WS_DoubleClick2
Option Explicit
Public lHOME As String, sperre2 As String, leerZeit As String, farbe As String, ov As String
Sub WS_DoubleClick2()
Dim ws As String, HOME As String, ENDE As String, erste As String, _
letzteTXT As String, letzteCOL As String
Dim z As Long, hZeile As Long, aktZeile As Long
Dim sp As Integer, leerSp As Integer, zoomAkt As Integer
Dim durchStd As Single
Dim m As Variant
sperre2 = ""
ws = ActiveSheet.NAME
HOME = Sheets(ws).Range("HOME").Address
sp = Range(HOME).Column
Application.Run "pepMAKROS.xlsm!BlattschutzNein"
z = Cells.SpecialCells(xlCellTypeLastCell).Row
ENDE = Sheets(ws).Cells(z, sp).End(xlUp).Address
lHOME = Sheets("Orga").Range("leerHOME").Address
hZeile = Range(HOME).Offset(-3, 0).Row
zoomAkt = ActiveWindow.zoom
'Prüft, ob in der aktuellen Zeile überhaupt Persoaldaten stehen
If Cells(ActiveCell.Row, sp).Value = "" Then
m = MsgBox("Ungültige Auswahl." & vbCrLf & "Die von Ihnen angeklickte Zelle befindet " & _
"sich in einer Leerzeile ohne Personaldaten.", vbOKOnly + vbExclamation, Title:="Hinweis")
GoTo ENDE
End If
'Koloriert den Bereich "Arbeitszeit" & "Pause" entsprechend den Leerzeiten gem. Blatt [Pers] _
und fügt den Text ein bzw löscht ihn ("farblos")
If Not ActiveWindow.zoom = 100 Then
Application.ScreenUpdating = False
ActiveWindow.zoom = 100
End If
frmLeerzeit.Show
If sperre2 = "J" Then
GoTo ENDE
Else
aktZeile = ActiveCell.Row
erste = ActiveCell.Offset(0, -(ActiveCell.Offset(-(aktZeile - hZeile)) - 1)).Address
letzteCOL = ActiveCell.Offset(0, 5 - ActiveCell.Offset(-(aktZeile - hZeile))).Address
letzteTXT = ActiveCell.Offset(0, 3 - ActiveCell.Offset(-(aktZeile - hZeile))).Address
Range(erste, letzteCOL).Interior.ColorIndex = farbe
If leerZeit = "" Then '"farblos" 7 zurücksetzen
Range(erste, letzteTXT).Value = ""
Else
With Range(erste).Offset(0, 2)
'Vermerkt den Leerzeitengrund im Arbeitsblatt
Range(.Address, letzteTXT).Value = leerZeit
If ov = "ov" Then 'Bei "Frei" und "ÜStd" werden die Zeiteinträge gelöscht
Range(letzteTXT, Range(letzteTXT).Offset(0, 1)).Offset(0, -2).ClearContents
Else
'Fügt pauschal "von"- und "bis"-Zeiten ein, sodass sich als Gesamtdauer die _
Ø tägliche ArbZeit des MA ergibt
durchStd = Cells(.Row, sp - 16).Value
Range(.Address, letzteTXT).Offset(0, -2).Value = Range(HOME).Offset(-2, -16).Value
Range(.Address, letzteTXT).Offset(0, -1).Value = _
Range(HOME).Offset(-2, -16).Value + Cells(.Row, sp - 16).Value / 24
End If
End With
End If
End If
ENDE:
ActiveWindow.zoom = zoomAkt
Application.ScreenUpdating = True
ActiveCell.Offset(0, 1).Select
Application.Run "pepMAKROS.xlsm!BlattschutzJa"
End Sub
Gruß, Rolf