Microsoft Excel

Herbers Excel/VBA-Archiv

Zeit erfassen | Herbers Excel-Forum


Betrifft: Zeit erfassen von: Fritz_W
Geschrieben am: 16.02.2012 18:53:33

Hallo VBA-Experten,

ich brauche erneut eure Hilfe:

Ich würde gerne die Zeit, die zwischen zwei Ereignissen vergeht, messen. Die (verstrichene) Zeit sollte in die Zelle J10 eingetragen werden.
Die 'Stoppuhrfunktion' sollte immer dann beginnen, wenn in der Zelle I1 eine neue Eingabe erfolgt.
Die Zeitnahme sollte enden, wenn der Zellwert der Zelle I2 den Wert 10 annimmt. (Der Zellwert in I2 wird über eine Formel erzeugt).

Ich freue mich über eure Unterstützung und danke im Voraus.

mfg
Fritz

  

Betrifft: AW: Zeit erfassen von: Josef Ehrensberger
Geschrieben am: 16.02.2012 19:36:01


Hallo Fritz,

Achte darauf, wo welche Code-Teile hingehören und dass das Klassenmodul den richtigen Name erhält.

Zelle J10 mit "hh:mm:ss,0" formatieren.

' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Workbook_Open()
  Call Tabelle1.StopTimer
End Sub


' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private WithEvents Timer1 As APITimer
Private dblTime As Double

Private Sub Worksheet_Calculate()
  If Not Timer1 Is Nothing Then
    If Timer1.Enabled Then
      If Range("I2") = 10 Then StopTimer
    End If
  End If
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address(0, 0) = "I1" Then
    If Timer1 Is Nothing Then
      Set Timer1 = New APITimer
    End If
    With Timer1
      If Not .Enabled Then
        Range("J10") = ""
        dblTime = Timer
        .IntervalMS = 100
        .Enabled = True
      End If
    End With
  End If
End Sub


Private Sub Timer1_Tick()
  On Error Resume Next
  Application.EnableEvents = False
  Range("J10") = (Timer - dblTime) / 86400
  Application.EnableEvents = True
End Sub


Public Sub StopTimer()
  On Error Resume Next
  Timer1.Enabled = False
End Sub


' **********************************************************************
' Modul: APITimer Typ: Klassenmodul
' **********************************************************************

Option Explicit


' benötigte API-Deklarationen
Private Declare Function SetTimer Lib "user32" ( _
  ByVal hWnd As Long, _
  ByVal nIdEvent As Long, _
  ByVal uElapse As Long, _
  ByVal lpTimerFunc As Long) As Long

Private Declare Function KillTimer Lib "user32" ( _
  ByVal hWnd As Long, _
  ByVal uIDEvent As Long) As Long

Private Declare Sub CopyMem Lib "kernel32" _
  Alias "RtlMoveMemory" ( _
  pDst As Any, _
  pSrc As Any, _
  ByVal cb As Long)

Private Declare Function VirtualAlloc Lib "kernel32" ( _
  lpAddress As Any, _
  ByVal dwSize As Long, _
  ByVal flAllocationType As Long, _
  ByVal flProtect As Long) As Long

Private Const MEM_COMMIT As Long = &H1000&

Private Declare Function VirtualFree Lib "kernel32" ( _
  lpAddress As Any, _
  ByVal dwSize As Long, _
  ByVal dwFreeType As Long) As Long

Private Const MEM_DECOMMIT As Long = &H4000&

Private Const PAGE_EXECUTE As Long = &H10&
Private Const PAGE_EXECUTE_READ As Long = &H20&
Private Const PAGE_EXECUTE_READWRITE As Long = &H40&

Private Const ASM_SIZE As Long = &HFF&

Private m_ptrCallback As Long
Private m_hdlTimer As Long
Private m_blnEnabled As Boolean
Private m_lngInterval As Long

Public Event Tick()

' muss erste öffentliche Methode in Interface sein!
' API Timer wird diese Methode aufrufen
Public Sub TimerCallback( _
    ByVal hWnd As Long, ByVal uMsg As Long, _
    ByVal idEvent As Long, ByVal dwTime As Long)

  
  RaiseEvent Tick
End Sub


' Aktiviert/Deaktiviert Timer (vgl. VB Intrinsic)
Public Property Get Enabled() As Boolean
  Enabled = m_blnEnabled
End Property


Public Property Let Enabled(ByVal blnValue As Boolean)
  If blnValue <> m_blnEnabled Then
    If blnValue Then
      m_hdlTimer = SetTimer(0, 0, IntervalMS, m_ptrCallback)
    Else
      KillTimer 0, m_hdlTimer
    End If
    m_blnEnabled = blnValue
  End If
End Property


' Bestimmt Interval, in dem Tick Event gefeuert wird
' (in Millisekunden)
Public Property Get IntervalMS() As Long
  IntervalMS = m_lngInterval
End Property


Public Property Let IntervalMS(ByVal lngMs As Long)
  m_lngInterval = lngMs
  
  If Enabled Then
    ' wird Interval geändert während Timer aktiv ist,
    ' muss er neu initialisiert werden
    Enabled = False
    Enabled = True
  End If
End Property


' Adresse erster öffentlicher Methode eines COM Interfaces ermitteln
Private Function GetFirstPublicMethod(ByVal obj As Object) As Long
  Dim pObj As Long
  Dim pVtbl As Long
  
  ' Adresse über VTable des Interfaces (IUnknown und IDispatch
  ' dort zuerst eingetragen, daher 7 Einträge = &H1C Bytes überspringen)
  CopyMem pObj, ByVal ObjPtr(obj), 4
  CopyMem pVtbl, ByVal pObj + &H1C, 4
  
  GetFirstPublicMethod = pVtbl
End Function


' Für ASM Callback genutzten Speicher freigeben
Private Sub FreeCallback(ByVal ptr As Long)
  VirtualFree ByVal ptr, ASM_SIZE, MEM_DECOMMIT
End Sub


' ASM Callback erstellen, das Timercallbacks an eine
' Methode der Klasse weiterleitet
Private Function CreateCallback(ByVal obj As Object, _
    ByVal addr As Long, ByVal params As Long) As Long

  
  Dim ptrMem As Long
  Dim ptrItr As Long
  Dim ptrNewAddr As Long
  Dim i As Long
  Dim j As Long
  
  ' ausführbaren Speicher vom System holen
  ' und Maschinencode reinschreiben
  ptrMem = VirtualAlloc(ByVal 0&, ASM_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
  If ptrMem = 0 Then
    Err.Raise 12345, , "VirtualAlloc fehlgeschlagen!"
  End If
  
  ptrItr = ptrMem
  
  For i = 1 To params
    CopyMem ByVal ptrItr + 0, &H2474FF, 3 ' PUSH [ESP+imm8]
    CopyMem ByVal ptrItr + 3, params * 4, 1
    ptrItr = ptrItr + 4
  Next
  
  CopyMem ByVal ptrItr + 0, &H68, 1 ' PUSH imm32
  CopyMem ByVal ptrItr + 1, ObjPtr(obj), 4
  ptrItr = ptrItr + 5
  
  ptrNewAddr = addr - ptrItr - 5
  
  CopyMem ByVal ptrItr + 0, &HE8, 1 ' CALL rel32
  CopyMem ByVal ptrItr + 1, ptrNewAddr, 4
  ptrItr = ptrItr + 5
  
  CopyMem ByVal ptrItr + 0, &HC2, 1 ' RET imm16
  CopyMem ByVal ptrItr + 1, params * 4, 2
  
  CreateCallback = ptrMem
End Function


Private Sub Class_Initialize()
  m_ptrCallback = CreateCallback(Me, GetFirstPublicMethod(Me), 4)
End Sub


Private Sub Class_Terminate()
  If Enabled Then Enabled = False
  FreeCallback m_ptrCallback
End Sub






« Gruß Sepp »



  

Betrifft: AW: Zeit erfassen von: Fritz_W
Geschrieben am: 16.02.2012 20:11:40

Hallo Sepp,

zunächst ganz herzlichen Dank.
Ich hab jetzt echt ein schlechtes Gewissen und zwar aus mehreren Gründen:

Kaum zu glauben, wie viel Arbeit du für uns Forumsbesucher investieren tust.

Dann habe ich Rückfragen und das obwohl Du ja schon reichlich Hinweise für die Anwendung des Codes gegeben hast:
Modul 'Diese Arbeitsmappe' ist mir klar, aber der Rest nicht so ganz.
Welcher Code muss in die betreffende Tabelle 'Lö' und welcher in ein Modul?
Bitte verzeih mir diese Fragen!

Vielen Dank für Deine Mühen und Dein Verständnis

und ganz herzlichen Gruß
Fritz


  

Betrifft: AW: Zeit erfassen von: Josef Ehrensberger
Geschrieben am: 16.02.2012 20:13:51


Hallo Fritz,

na so aufwändig ist das gar nicht.

Anbei eine Beispieldatei.

https://www.herber.de/bbs/user/78952.xls



« Gruß Sepp »



  

Betrifft: AW: Zeit erfassen von: Fritz_W
Geschrieben am: 16.02.2012 20:26:38

Hallo Sepp,

wenn Du das so siehst, zeigt das nur, welch großer Könner Du bist.
Die Beispieldatei funktioniert genau so, wie ich das wollte.
Einfach Spitze und nochmals vielen herzlichen Dank!

Viele Grüße
Fritz


  

Betrifft: Zeiterfassungsalternative von: Luc:-?
Geschrieben am: 16.02.2012 20:01:31

Hallo Fritz,
viell reicht für deine Zwecke ja auch folgende Vorgehensweise aus:
1. Im Dokument-Klassenmodul des Blattes die Ereignisprozedur Worksheet_Change anlegen.
2. Statt der Leerzeile Folgendes eintragen:

    Const koEndWert As Double = 10.001, adRelZellen$ = "I1 I2 J10"
    Static StartZeit As Double
    Dim arZAdressen As Variant, ezAnzeige As Range, ezEingabe As Range, ezVergleich As Range
    arZAdressen = Split(adRelZellen): Set ezEingabe = Me.Range(arZAdressen(0))
    Set ezVergleich = Me.Range(arZAdressen(1)): Set ezAnzeige = Me.Range(arZAdressen(2))
    If Not Intersect(Target, ezEingabe) Is Nothing Then
        If CBool(StartZeit) And ezVergleich < koEndWert Then 
            ezAnzeige = Now - StartZeit
        Else: StartZeit = Now * Abs(ezVergleich < koEndWert)
        End If
    End If
    Set ezAnzeige = Nothing: Set ezEingabe = Nothing: Set ezVergleich = Nothing
3. J10 enthält dann eine normale Dezimalzahl doppelter Genauigkeit, die du als Sekunden, Minuten oder wie auch immer du die Zeit messen willst, formatieren kannst.
Allerdings funktioniert das nur, solange die Mappe offen ist. Soll die Messung auch über Schließungszeiten der Mappe erfolgen, muss die Variable StartZeit irgendwo in der Mappe zwischengespeichert wdn und bei der 1.Änderung anstelle von Now in die zwischenzeitlich gelöschte Variable übernommen wdn.
Gruß Luc :-?


  

Betrifft: AW: Zeiterfassungsalternative von: Fritz_W
Geschrieben am: 16.02.2012 20:28:07

Hallo Luc,

ganz herzlichen Dank für Deine Hilfe.
Werde es testen und gebe morgen Rückmeldung.

Viele Grüße
Fritz


  

Betrifft: AW: Zeiterfassungsalternative von: Fritz_W
Geschrieben am: 17.02.2012 11:01:48

Hallo Luc,

leider habe ich beim Umsetzen deines Vorschlags die gleichen (leidvollen) Defizite meiner VBA-Kenntnisse erfahren müssen.

Obwohl Sepps Lösung nunmehr meine Bedürfnisse in volllem Umfang abdeckt, wollte ich - da ich dankbar für jede Unterstützung von euch Experten bin - auch gerne prüfen, wieweit sich auch Dein Vorschlag realisieren ließe.

(Nur) Wenn es Dir nicht zu viel Umstände bereitet, würde ich mich über einige zusätzliche Erläuterungen (bezüglich deiner nachfolgenden Hinweise) freuen:

1. Im Dokument-Klassenmodul des Blattes die Ereignisprozedur Worksheet_Change anlegen.
2. Statt der Leerzeile ...

Auch Dir schon jetzt vielen Dank für Dein Verständnis und die Unterstützung

mfg
Fritz


  

Betrifft: Über dem HptFenster des VBEditors befinden ... von: Luc:-?
Geschrieben am: 17.02.2012 20:32:52

…sich 2 DropDown-Fensterchen, Fritz.
Wenn du im Linken Worksheet auswählst, wird automatisch die Standard-Ereignisprozedur dafür angelegt. Das wäre hier Worksheet_SelectionChange. Da du die aber nicht brauchst, hast du 2 Möglichkeiten:
1. Im rechten DropDown-Fensterchen jetzt Change auswählen und dann die andere wieder löschen;
2. Nur das Selection aus dem Prozedurnamen entfernen, denn ansonsten sind beide Prozedur-Köpfe gleich aufgebaut wie du am rechten DropDown-Fensterchen sehen kannst, denn da ist jetzt Change fett hervorgehoben.
Das findest du auch alles in der VBE-Hilfe (→ ?Hilfe zur VisualBasic-Benutzeroberfläche)!
Gruß Luc :-?


  

Betrifft: AW: Über dem HptFenster des VBEditors befinden ... von: Fritz_W
Geschrieben am: 18.02.2012 10:41:36

Hallo Luc,

nochmals ganz herzlichen Dank für die weitere Unterstützung.
Dank Deiner zusätzlichen Hinweise hab ich es tatsächlich geschafft, dass eine Zeitnahme erfolgt und diese in J10 ausgegeben wird.
Allerdings wird die Ausgabe ausgelöst, wenn eine Eingabe in I1 erfolgt (dadurch sollte jedoch der Start ausgelöst werden). Desweiteren erfolgt die Zeitnahme immer fortlaufend, d.h. bei erneuter Ausgabe wird die ursprüngliche Zeit mitgerechnet.

Hast Du die Aufgabenstellung falsch interpretiert oder woran liegt das?

Viele Grüße
Fritz


  

Betrifft: Ja, ich hatte das ganz anders verstanden, ... von: Luc:-?
Geschrieben am: 18.02.2012 15:58:33

…Fritz;
in meinem Gedächtnis blieb vorrangig Zeit zwischen 2 Ereignissen messen hängen; die 'Stoppuhrfunktion', die immer dann beginnen (sollte), wenn in der Zelle I1 eine neue Eingabe erfolgt, war dann nur noch marginal, da ich ja nicht wusste, was die Fml in I2 macht und was du als Ereignis ansiehst. Ich ging von einer Startaktion im TabBlatt aus, die mehrfach erfolgen kann bis der Endwert in I2 (wie auch immer und in welchen Zeitintervallen) erreicht ist. Deshalb auch meine Bemerkung mit der Unterbrechung über zwischenzeitl Beenden von Xl. Infolgedessen wird die insgesamt vergangene Zeit seit Erststart einbezogen und der jeweilige Zwischenstand sofort aktualisiert in J10 angezeigt. Damit ist erst Schluss, wenn I2 den Endwert erreicht bzw überschreitet.
Für Sepp hingg war wohl 'Stoppuhrfunktion' das entscheidende Stichwort. Aber mit den seiner Lösung zugrunde liegenden API-Fktt beschäftige ich mich kaum, da das weniger mit Xl als mit Windows zu tun hat. Denn auch im Kern-Xl gibt's genug Interessantes (in das wohl auch MS nur ungern eingreift) als dass ich mich als Windows-Programmierer versuchen müsste. Das sollen mal die Profi-Programmierer machen, denn das ist schlicht ihr Handwerkszeug. Dahin gehen meine Intentionen nicht.
Gruß+schöWE, Luc :-?


  

Betrifft: AW: Ja, ich hatte das ganz anders verstanden, ... von: Fritz_W
Geschrieben am: 18.02.2012 17:43:12

Hallo Luc,

vieleln Dank für deine Infos und Deine Mühen.

Viele Grüße
Fritz


  

Betrifft: 'Mühe' ist etwas übertrieben, aber danke! ;-) orT von: Luc:-?
Geschrieben am: 18.02.2012 17:51:51

Gruß Luc :-?


Beiträge aus den Excel-Beispielen zum Thema "Zeit erfassen"