nicht erschrecken! jetzt kommen gut 150 Zeilen Code! Die können aber 1:1 in ein Tabellenblatt kopiert werden und schon hat man einen bequemen kleinen Stundenzettel (engl. TimeSheet). Der Code ist so dokumentiert, dass man hoffentlich nachvollziehen kann, was denn da auf Doppelklick-Basis so passiert.
Wie funktioniert's? Einfach den Code hier markieren und in ein Arbeitsblatt (Rechtsklick auf Tabellenreiter > Code anzeigen) einfügen. Im Arbeitsblatt sieht man jetzt erst einmal noch nichts, findet aber mit Alt+F8 zwei neue Makros: ActivitySetup und ~Summary.
Mit ~Setup wird das Layout und die Funktionalität des TimeSheets (sorry, alles in english, war so gewünscht) eingerichtet und mit wenigen Beispieldaten gefüllt. Kann man nach Tests auch zum Reset nutzen.
Dann genügt ein Doppelklick auf einen der Jobs (Spalte A) und es passiert dies: Der Job wird mit Datum und Uhrzeit in die Tabelle ab Spalte B eingefügt. Dabei wird die Uhrzeit auf Viertelstunden gerundet (auf wie ab). Ist der Job erledigt, braucht's wieder 'nen Doppelklick, diesmal in die grün markierte Zelle und die benötigte Zeit wird ermittelt. Manuell kann man noch eventuelle Ausgaben vermerken oder auch die automatisch eingetragenen Zeitwerte ändern (erst löschen, dann neu eingeben, dann Doppelklick in die Zelle in Spalte F.
Das Makro ~Summary berechnet die Summenwerte aus den Eingaben und gibt sie auf Wunsch als hardcopy auf dem Standarddrucker aus.
So - und nun Deckung! Hier kommt de Code:
Code: Alles auswählen
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
If Target.Row > 1 Then 'protects the headlline
Select Case Target.Column 'select activity
Case 1
ActivityStart Target.Value
Case 5 'end activity
ActivityEnd Target.Row
End Select
End If
End Sub
Sub ActivityStart(sJob As String)
Dim r As Integer, vTime
r = Cells(Rows.Count, 2).End(xlUp).Row + 1 'first empty row in activity
Columns(5).Interior.Color = xlNone 'reset highlight
vTime = Round(Time * 24 / (1 / 4), 0) * (1 / 4) / 24 'rounds current time to 15 mins
Cells(r, 2) = sJob 'as send by double click
Cells(r, 3) = Date 'system date
Cells(r, 4) = vTime 'as rounded above
Cells(r, 5).Interior.Color = 14348258 'highlight
Cells(r, 5).Activate 'set target
End Sub
Sub ActivityEnd(r As Integer)
Dim vTime, dDuration As Date, sDuration As String
If Cells(r, 5) = "" Then
vTime = Round(Time * 24 / (1 / 4), 0) * (1 / 4) / 24 'rounds current time to 15 mins
Cells(r, 5) = vTime
End If
dDuration = Cells(r, 5) - Cells(r, 4) 'calculates the needed time
sDuration = Int(CSng(dDuration * 24)) & ":" & Format(dDuration, "nn") 'formatting the time value to hours:mins
Cells(r, 6) = sDuration
Columns(5).Interior.Color = xlNone 'reset highlight
End Sub
Sub ActivitySummary()
Dim wsf As WorksheetFunction
Dim f As Byte, i As Integer, r As Integer
Dim sMsg As String, sName As String, sFile As String
Dim dStart As Date, dEnd As Date, iDays As Integer
Dim Hours As Double, sHours As String
Dim Expenses As Double, sExpenses As String
Dim aDesc, aVal, rng As Range
Set wsf = WorksheetFunction 'avoids the neverending syntax
r = Cells(Rows.Count, 2).End(xlUp).Row
sFile = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) 'cuts the extension
dStart = wsf.Min(Columns(3)) 'first entry
dEnd = wsf.Max(Columns(3)) 'last entry
iDays = DateDiff("d", dStart, dEnd) + 1
Hours = wsf.Sum(Columns(6)) * 24 'converts hours2dec
sHours = Format(Hours, "0.00")
Expenses = wsf.Sum(Columns(7)) 'just a sum
sExpenses = Format(Expenses, "0.00")
sName = Application.UserName 'who's playing around here?
'mergin and formatting all info to a string / msgbox
sMsg = "Summary from " & dStart & " to " & dEnd & " = " & iDays & " days." & vbNewLine & vbNewLine & vbTab
sMsg = sMsg & "In total there were " & sHours & " hours of work" & vbNewLine & vbTab
sMsg = sMsg & "and " & sExpenses & " EUR of expenses." & vbNewLine
sMsg = sMsg & vbNewLine & vbTab & "Do you need a hardcopy?"
f = MsgBox(sMsg, 259, "ActivitySummary for " & sName & " | " & sFile) 'forked to save paper for unnecessary hardcopies
Select Case f
Case 6
GoTo PRN
Case Else
Exit Sub
End Select
PRN:
aDesc = Array("Summary", "Name", "Start", "End", "Days", "Hours", "Expenses", "Date", "Signature", "Confirmed")
aVal = Array(sFile, sName, dStart, dEnd, iDays, sHours, sExpenses, Date)
'populate some tmp cells for a hardcopy
For i = 0 To UBound(aDesc) 'cell descriptions
Cells(i + 2, 10) = aDesc(i)
Next i
For i = 0 To UBound(aVal) 'cell values
Cells(i + 2, 11) = aVal(i)
Cells(i + 2, 11).HorizontalAlignment = xlRight
Next i
Set rng = Range(Cells(2, 9), Cells(2, 11))
With rng.Font 'formats for the headline
.Size = 14
.Bold = True
End With
Set rng = Range(Cells(1, 9), Cells(11, 11))
With rng
'.PrintOut Copies:=1 'print the defined rng
.Clear 'clear the tmp cells
End With
Cells(1, 1).Activate
End Sub
Sub ActivitySetup()
Dim i As Integer, aRow, aWidth
aRow = Array("Select / add activity", "Activity", "Date", "Start", "End", "Time", "Expenses", "Item #")
aWidth = Array("30", "30", "10", "10", "10", "10", "10", "20", "10", "20", "30")
Cells.Clear
For i = 0 To UBound(aRow) 'headline + formats
Cells(1, i + 1) = aRow(i)
Cells(1, i + 1).HorizontalAlignment = xlCenter
Cells(1, i + 1).Font.Bold = True
Next i
For i = 2 To 6 'some sample jobs
Cells(i, 1) = "Job " & i - 1
Next i
For i = 4 To 6 'format cols to Short Time
Columns(i).NumberFormat = "hh:mm"
Next i
Columns(7).NumberFormat = "0.00" 'format to Number
For i = 0 To UBound(aWidth) 'ColumnWidth
Columns(i + 1).ColumnWidth = aWidth(i)
Next i
With ActiveWindow 'headline freeze
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
End With
Cells(1, 1).Activate
End Sub
Der Code liegt bisher ausschließlich in der Tabelle, ganz ohne ein Modul oder Userform oder ... und ist dadurch natürlich noch sehr ausbaufähig. Z.B. mit jeweils einer Tabelle pro Baustelle, Kalender-gesteuerten Abrechnungen, einer Ausgabenverwaltung und Abrechnung, und, und, und. Wer das nicht selber machen kann/will - einfach anfragen (PN). Eine deutsche/anderssprachige Fassung wird wohl kaum ein Problem sein.
Liebe Grüße und viel Spaß damit!