AW: Lösung für automatisches Ausrechnen
18.03.2005 14:12:41
Frank
Hallo Struppi,
ich weiß nicht, wie Du das wieder gut machen willst ;-)
Sub Berechne_Ausfallzeit()
Dim rg As Range
Dim lngCurRow As Long
Dim lngLastRow As Long
Dim lngCurAnlage As Long
Dim dteStart As Date
Dim dteEnde As Date
Dim dteDiff As Date
lngLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
Set rg = Range("A2", Cells.SpecialCells(xlCellTypeLastCell))
' Zunächst temporär die Anlage-Bereit Meldung in Statusmeldung übertragen
For lngCurRow = 2 To lngLastRow
If (Not IsDate(Cells(lngCurRow, "F"))) And (Not IsDate(Cells(lngCurRow, "G"))) Then
If IsDate(Cells(lngCurRow, "H")) And Len(Cells(lngCurRow, "I") & "") > 2 Then
Cells(lngCurRow, "F") = Cells(lngCurRow, "H")
Cells(lngCurRow, "G") = Cells(lngCurRow, "I")
End If
End If
Next lngCurRow
' Liste nach Anlage, Datum, Uhrzeit sortieren
rg.Sort Key1:=Range("E2"), _
Order1:=xlAscending, _
Key2:=Range("F2"), _
Order2:=xlAscending, _
Key3:=Range("G2"), _
Order3:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal
' Startzeile
lngCurRow = 2
' Hier fängst an
Do While lngCurRow <= lngLastRow
If UCase(Range("D" & lngCurRow)) = UCase("Nein") Then
' Ausfall gefunden
lngCurAnlage = Range("E" & lngCurRow)
dteStart = CDate(Range("F" & lngCurRow).Text & " " & Range("G" & lngCurRow).Text)
' Jetzt Ende des Ausfalls suchen
Do
lngCurRow = lngCurRow + 1
If (lngCurRow <= lngLastRow) And (lngCurAnlage = Range("E" & lngCurRow)) Then
' Erst wurde geprüft, ob wir noch im definierten
' Bereich und in der aktuellen Anlage sind
If UCase(Range("D" & lngCurRow)) = UCase("Ja") Then
' Nach der jetzigen Sortierung sollte "Ja" stehen
dteEnde = CDate(Range("F" & lngCurRow).Text & " " & Range("G" & lngCurRow).Text)
dteDiff = dteEnde - dteStart
If Range("J" & lngCurRow).Text <> Format(dteDiff, "hh:mm") Then
Range("J" & lngCurRow) = Format(dteDiff, "hh:mm")
Range("J" & lngCurRow) = Format(dteDiff, "hh:mm")
End If
lngCurRow = lngCurRow + 1
Exit Do
End If
End If
Loop While (lngCurRow <= lngLastRow) And (lngCurAnlage = Range("E" & lngCurRow))
Else
lngCurRow = lngCurRow + 1
End If
Loop
' Liste wieder nach Datum und Uhrzeit sortieren
rg.Sort Key1:=Range("F2"), _
Order1:=xlAscending, _
Key2:=Range("G2"), _
Order2:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal
'Fertig!!!
End Sub
Übringst hast Du einige Berechnungsfehler!
Viel Spaß
Frank.