Option Explicit
Sub SuchenUndErsetzen()
Dim blSearchDirectionIsAscending As Boolean
Dim blIdIsAvailableAtTime As Boolean
Dim intColumn As Integer
Dim lngRow As Long
Dim lngLastrow As Long
Dim i As Integer
Dim strID As String
Dim strIDAtTime As String
Dim strNewValue As String
Dim wsIndex As Worksheet
Dim wsResult As Worksheet
Dim intMinTime As Integer
Dim intMaxTime As Integer
Dim intStartTime As Integer
Dim intCurrentTime As Integer
Dim nextTime As Integer
Set wsIndex = Sheets("Index")
Set wsResult = Sheets("Result")
With wsIndex
lngLastrow = .Cells(Rows.Count, 1).End(xlUp).row
.Range(.Cells(1, 1), .Cells(lngLastrow, 4)).Copy
End With
With wsResult
.UsedRange.Clear
.Cells(1, 2).PasteSpecial xlPasteAll
intMinTime = .Cells(2, 2).Value
intMaxTime = .Cells(lngLastrow, 2).Value
End With
wsResult.Cells(1, 1).Value = "Zeitraum - ID"
For i = 2 To lngLastrow
With wsResult
intStartTime = .Cells(i, 2).Value
strID = .Cells(i, 3).Value
strIDAtTime = intStartTime & strID
.Cells(i, 1).Value = intStartTime & strID
.Cells(i, 6).Value = strID & .Cells(i, 4)
.Cells(i, 7).Value = strID & .Cells(i, 5)
End With
Next i
With wsResult
For intColumn = 4 To 5
For lngRow = 2 To lngLastrow
If .Cells(lngRow, intColumn).Value = "N/A" Then
intStartTime = .Cells(lngRow, 2).Value
strID = .Cells(lngRow, 3).Value
If Application.WorksheetFunction.CountIf(.Range(.Cells(2, 3), .Cells(lngLastrow, 3)), strID) = _
Application.WorksheetFunction.CountIf(.Range(.Cells(2, intColumn + 2), .Cells(lngLastrow, intColumn + 2)), .Cells(lngRow, intColumn + 2).Value) Then
.Cells(lngRow, intColumn).Value = 0
.Cells(lngRow, intColumn).Interior.ColorIndex = 9
Else
.Cells(lngRow, intColumn).Interior.ColorIndex = 8
strIDAtTime = .Cells(lngRow, 1).Value
intCurrentTime = .Cells(lngRow, 2)
CheckAgain:
blSearchDirectionIsAscending = searchDirectionIsAscending(intCurrentTime, intMaxTime, intStartTime)
nextTime = getNewTime(intMinTime, intMaxTime, intStartTime, intCurrentTime, blSearchDirectionIsAscending)
If nextTime = -1 Then
strNewValue = 0
.Cells(lngRow, intColumn).Value = strNewValue
.Cells(lngRow, intColumn).Interior.ColorIndex = 6
GoTo EndLoop
End If
strIDAtTime = nextTime & strID
blIdIsAvailableAtTime = isIdAvailableAtTime(strIDAtTime)
If blIdIsAvailableAtTime = True Then
strNewValue = valueOfIdAtTime(strIDAtTime, intColumn)
If strNewValue = "N/A" Then
intCurrentTime = nextTime
GoTo CheckAgain
End If
.Cells(lngRow, intColumn).Value = strNewValue
.Cells(lngRow, intColumn).Interior.ColorIndex = 5
Else
nextTime = getNewTime(intMinTime, intMaxTime, intStartTime, intCurrentTime, blSearchDirectionIsAscending)
intCurrentTime = nextTime
GoTo CheckAgain
End If
End If
End If
EndLoop:
Next lngRow
Next intColumn
End With
wsResult.Range("A:A,F:F,G:G").Delete
End Sub
Function isIdAvailableAtTime(strIDAtTime As String) As Boolean
Dim rngVlookup As Range
Dim strResult As String
Dim lngLastrow As Long
With Sheets("Result")
lngLastrow = .Cells(Rows.Count, 1).End(xlUp).row
Set rngVlookup = .Range(.Cells(2, 1), .Cells(lngLastrow, 1))
On Error GoTo ErrorHandler
strResult = Application.WorksheetFunction.VLookup(strIDAtTime, rngVlookup, 1, False)
isIdAvailableAtTime = True
Exit Function
End With
ErrorHandler:
isIdAvailableAtTime = False
End Function
Function valueOfIdAtTime(strIDAtTime As String, intColumn As Integer) As String
Dim rngVlookup As Range
Dim strResult As String
Dim lngLastrow As Long
With Sheets("Result")
lngLastrow = .Cells(Rows.Count, 1).End(xlUp).row
Set rngVlookup = .Range(.Cells(2, 1), .Cells(lngLastrow, intColumn))
valueOfIdAtTime = Application.VLookup(strIDAtTime, rngVlookup, intColumn, False)
End With
End Function
Function searchDirectionIsAscending(intCurrentTime As Integer, intMaxTime As Integer, startTime As Integer) As Boolean
If intCurrentTime = intMaxTime Then
searchDirectionIsAscending = False
ElseIf intCurrentTime < startTime Then
searchDirectionIsAscending = False
Else
searchDirectionIsAscending = True
End If
End Function
Function getNewTime(minTime As Integer, maxTime As Integer, startTime As Integer, currentTime As Integer, searchDirectionIsAscending As Boolean) As Integer
Select Case currentTime
Case Is < maxTime:
If searchDirectionIsAscending = True Then
getNewTime = currentTime + 1
Else
getNewTime = currentTime - 1
End If
Case Is = maxTime:
getNewTime = startTime - 1
End Select
End Function