Zählen wenn, Zeitabhängigkeit

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi Frank,
das ist für mich eine echt harte Nuss, ich weiß dass der Code wahrscheinlich noch nicht so funktioniert wie gewünscht:

Sub Frank()
Dim cell, cell1 As Range, myRange, myRange1 As Range
Dim Counter As Long, i, j As Long
Set myRange = Range(Cells(1, 1), Cells(Cells.SpecialCells(xlCellTypeLastCell).Row, 1))
'Spalte A / Datum
Set myRange1 = Range(Cells(1, 4), Cells(Cells.SpecialCells(xlCellTypeLastCell).Row, 4))
'Spalte D / Zählspalte
'Datum und Zeit zusammenfügen und als Zahl ausgeben
For Each cell In myRange
Cells(cell.Row, 3) = CDbl(Cells(cell.Row, 1) + Cells(cell.Row, 2))
Next cell
'Zahlen in Spalte D zählen
For Each cell1 In myRange1
If cell1.Row > 1 Then
For i = cell1.Row - 1 To 1 Step -1 'Gehe alle früheren Werte durch, bis Ende oder Zä _
hlung
If cell1 = cell1.Offset(-cell1.Row + i, 0) Then 'Bei gleichen aufeinanderfolgenden  _
Werten
If (cell1.Offset(0, -1) - cell1.Offset(-cell1.Row + i, -1)) > 0.014 Then
'0,014 entspricht etwa 20 Minuten
Counter = Counter + 1
'Nur zählen, wenn ein gleicher Wert vor mehr als 20 Min vorhanden ist
Exit For
End If
Else
j = i
'Wenn die Werte ungleich sind, prüfe ob in den letzten 20 Minuten der gleiche  _
Wert vorkam
Do While (cell1.Offset(0, -1) - cell1.Offset(-cell1.Row + j, -1))  1
If cell1 = cell1.Offset(-cell1.Row + j, 0) Then GoTo Weiter
j = j - 1
Loop
Counter = Counter + 1 'Ansonsten Zählung
Exit For
End If
Weiter:
Next i
Else
Counter = Counter + 1 'Erste Zeile wird immer gezählt
End If
Next cell1
MsgBox "Zähler steht bei " & Counter
Set myRange = Nothing
Set myRange1 = Nothing
End Sub

Ich kann schwer prüfen, ob er so zählt wie er soll. Ich vermute aber, dass er bei gleichen aufeinanderfolgenden Werten falsch verfährt. Er schaut dann nämlich, ob irgendwo in der Spalte darüber der gleiche Wert steht mit mehr als 20 Minuten dazwischen. An sich nicht verkehrt, er ignoriert aber eventuelle spätere gleiche Werte und ich vermute, dass nur zwischen dem letzten gleichen Wert mindestens 20 Minuten vergangen sein müssen?
Vielleicht nutzt einer der Experten ja dies als Anstoß, noch weiter zu optimieren?
Grüße
Daniel

Hallo Daniel,
vorab vielen Dank, dass du dich mit dem Thema auseinandergesetzt hast. Das war schon clever, die Datums - und Zeitspalte jeweils in einer Zelle darzustellen, um den Tageswechsel zu berücksichtigen.
Ich lade nochmals eine Datei hoch, in der in der Spalte K die "Zählerstände" anzeigt werden. Wenn ich mich jetzt nicht verzählt haben sollte, müsste der Zähler beim durchlaufen des Codes bei 49 stehen.
Zu deiner Vermutung:
Angenommen es stehen in Spalte D, drei 7 untereinander dann wäre gut, wenn er die letzte als zeitlichen Bezugspunkt nimmt. Wenn es programmiertechnisch einfacher ist die Erste zu nehmen, dann soll es so sein - ist nicht entscheidend.
Müsste er nicht theoretisch die Abfrage bei jeder Zeile durchführen?
https://www.herber.de/bbs/user/127240.xlsm
Gruß Frank

Sub Frank() Dim cell, cell1 As Range, myRange, myRange1 As Range Dim Counter As Long, i, j As Long Set myRange = Range(Cells(1, 1), Cells(Cells.SpecialCells(xlCellTypeLastCell).Row, 1)) 'Spalte A / Datum Set myRange1 = Range(Cells(1, 4), Cells(Cells.SpecialCells(xlCellTypeLastCell).Row, 4)) 'Spalte D / Zählspalte 'Datum und Zeit zusammenfügen und als Zahl ausgeben For Each cell In myRange Cells(cell.Row, 3) = CDbl(Cells(cell.Row, 1) + Cells(cell.Row, 2)) Next cell 'Zahlen in Spalte D zählen For Each cell1 In myRange1 If cell1.Row > 1 Then For i = cell1.Row - 1 To 1 Step -1 'Gehe alle früheren Werte durch, bis Ende oder Zä _ hlung If cell1 = cell1.Offset(-cell1.Row + i, 0) Then 'Bei gleichen aufeinanderfolgenden _ Werten If (cell1.Offset(0, -1) - cell1.Offset(-cell1.Row + i, -1)) > 0.014 Then '0,014 entspricht etwa 20 Minuten Counter = Counter + 1 cell1.Offset(0, 2) = Counter 'Nur zählen, wenn ein gleicher Wert vor mehr als 20 Min vorhanden ist Exit For Else Exit For End If Else j = i 'Wenn die Werte ungleich sind, prüfe ob in den letzten 20 Minuten der gleiche _ Wert vorkam Do While (cell1.Offset(0, -1) - cell1.Offset(-cell1.Row + j, -1)) 1 If cell1 = cell1.Offset(-cell1.Row + j, 0) Then GoTo Weiter j = j - 1 Loop Counter = Counter + 1 'Ansonsten Zählung cell1.Offset(0, 2) = Counter Exit For End If Weiter: Next i Else Counter = Counter + 1 'Erste Zeile wird immer gezählt cell1.Offset(0, 2) = Counter End If Next cell1 MsgBox "Zähler steht bei " & Counter Set myRange = Nothing Set myRange1 = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread