AW: Prüfung Arbeitszeiten
24.05.2012 12:05:57
Rudi
Hallo,
ganz schön komplex.
Mein Weg:
Option Explicit
Sub CheckTimes()
Dim arr(), lRow As Long, lCol As Long, lCounter As Long, arrRead
ReDim arr(1 To Application.Count(Columns("C:F")), 1 To 3)
arrRead = Array(4, 6, 3, 5)
For lRow = 2 To Cells(Rows.Count, 1).End(xlUp).Row
For lCol = 0 To 3
If Cells(lRow, arrRead(lCol)) "" Then
lCounter = lCounter + 1
arr(lCounter, 1) = Cells(lRow, 1)
arr(lCounter, 2) = Cells(lRow, arrRead(lCol))
arr(lCounter, 3) = Cells(1, arrRead(lCol))
End If
Next
Next
prcSort Array(1, 2), arr
With Worksheets.Add
.Cells(1, 1) = "Datum"
.Cells(1, 2) = "Zeit"
.Cells(1, 3) = "Typ"
.Cells(2, 1).Resize(UBound(arr), 3) = arr
.Columns(2).NumberFormat = "hh:mm"
For lRow = 2 To UBound(arr) + 1
If Application.CountIf(.Columns(1), .Cells(lRow, 1)) Mod 2 0 Then
'ungerade Anzahl Buchungen
.Cells(lRow, 1).Interior.Color = RGB(255, 0, 0)
End If
If .Cells(lRow, 1) = .Cells(lRow - 1, 1) And .Cells(lRow, 1) = .Cells(lRow + 1, 1) Then
If .Cells(lRow, 2) .Cells(lRow - 1, 2) And .Cells(lRow, 2) .Cells(lRow + 1, 2) _
Then
.Cells(lRow, 2).Interior.Color = RGB(255, 0, 0)
End If
End If
Next
End With
End Sub
Sub prcSort(vntSortKey As Variant, vntArray() As Variant)
Dim intIndex As Integer
Dim lngIndex1 As Long, lngIndex2 As Long, lngRowsArray() As Long
Dim lngRowsCount As Long, lngRangeCount As Long
Dim vntTemp As Variant
ReDim lngRowsArray(0 To 1, 0 To UBound(vntArray) * 2)
Dim i As Integer
'Array für den 1. Sortierlauf
lngRowsArray(0, 0) = LBound(vntArray)
lngRowsArray(0, 1) = UBound(vntArray)
lngRowsCount = 1
For intIndex = LBound(vntSortKey) To UBound(vntSortKey)
'Wenn eine Spalte angegeben
If vntSortKey(intIndex) 0 Then
lngRangeCount = -1
'Schleife zum sortieren der einzelnen Bereiche
For lngIndex1 = 0 To lngRowsCount Step 2
'Sortieren des Bereichs, wenn Zeilenzahl größer 1
If lngRowsArray(0, lngIndex1) lngRowsArray(0, lngIndex1 + 1) Then
Call prcQuickSort(CLng(lngRowsArray(0, lngIndex1)), _
CLng(lngRowsArray(0, lngIndex1 + 1)), CInt(Abs(vntSortKey(intIndex))), _
_
CBool(vntSortKey(intIndex) > 0), vntArray())
'sortierten Bereich merken
lngRangeCount = lngRangeCount + 2
lngRowsArray(1, lngRangeCount - 1) = lngRowsArray(0, lngIndex1)
lngRowsArray(1, lngRangeCount) = lngRowsArray(0, lngIndex1 + 1)
End If
Next
lngRowsCount = -1
'Durchsuchen der soeben sortierten Spalte nach Wertewechsel
For lngIndex1 = 0 To lngRangeCount Step 2
'1. Zeile des zu sortierenden Bereichs
vntTemp = vntArray(lngRowsArray(1, lngIndex1), Abs(vntSortKey(intIndex)))
lngRowsCount = lngRowsCount + 1
lngRowsArray(0, lngRowsCount) = lngRowsArray(1, lngIndex1)
'Suche nach Wechsel innerhalb des Bereichs
For lngIndex2 = lngRowsArray(1, lngIndex1) To lngRowsArray(1, lngIndex1 + 1)
If vntTemp vntArray(lngIndex2, Abs(vntSortKey(intIndex))) Then
lngRowsCount = lngRowsCount + 2
lngRowsArray(0, lngRowsCount - 1) = lngIndex2 - 1
lngRowsArray(0, lngRowsCount) = lngIndex2
vntTemp = vntArray(lngIndex2, Abs(vntSortKey(intIndex)))
End If
Next
'letzte Zeile des zu sortierenden Bereichs
lngRowsCount = lngRowsCount + 1
lngRowsArray(0, lngRowsCount) = lngRowsArray(1, lngIndex1 + 1)
Next
End If
Next
End Sub
Private Sub prcQuickSort(lngLbound As Long, lngUbound As Long, _
intSortColumn As Integer, bntSortKey As Boolean, vntArray() As Variant)
Dim intIndex As Integer
Dim lngIndex1 As Long, lngIndex2 As Long
Dim vntTemp As Variant, vntBuffer As Variant
lngIndex1 = lngLbound
lngIndex2 = lngUbound
vntBuffer = vntArray((lngLbound + lngUbound) \ 2, intSortColumn)
Do
If bntSortKey Then
Do While vntArray(lngIndex1, intSortColumn) vntBuffer
lngIndex1 = lngIndex1 + 1
Loop
Do While vntBuffer > vntArray(lngIndex2, intSortColumn)
lngIndex2 = lngIndex2 - 1
Loop
End If
If lngIndex1 _
vntArray(lngIndex2, intSortColumn) Then
For intIndex = LBound(vntArray, 2) To UBound(vntArray, 2)
vntTemp = vntArray(lngIndex1, intIndex)
vntArray(lngIndex1, intIndex) = _
vntArray(lngIndex2, intIndex)
vntArray(lngIndex2, intIndex) = vntTemp
Next
End If
lngIndex1 = lngIndex1 + 1
lngIndex2 = lngIndex2 - 1
ElseIf lngIndex1 = lngIndex2 Then
lngIndex1 = lngIndex1 + 1
lngIndex2 = lngIndex2 - 1
End If
Loop Until lngIndex1 > lngIndex2
If lngLbound
Gruß
Rudi