Hallo Stephan,
ich weiß zwar nicht, ob dies best practise ist, aber es erfüllt Deine Anforderungen.
Ich habe jedoch einen weiteren "Result" in der Tabelle angelegt (Dies müsstest Du auch machen).
So bleiben Deine Originaldaten erhalten. Die Ergebnisse werden dann im Reiter "Result" angezeigt.
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")
'Originaldaten in Reiter Result kopieren
With wsIndex
'letzteZeile Ermitteln ermitteln
lngLastrow = .Cells(Rows.Count, 1).End(xlUp).row
.Range(.Cells(1, 1), .Cells(lngLastrow, 4)).Copy
End With
'ID und Startzeitraum in Reiter StartTime kopieren
With wsResult
.UsedRange.Clear
.Cells(1, 2).PasteSpecial xlPasteAll
intMinTime = .Cells(2, 2).Value
intMaxTime = .Cells(lngLastrow, 2).Value
End With
'Zeit und ID für Suche per SVerweis verketten und in Spalte A eintragen
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
'Durchlauf der Wertespalten
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
'Prüfung, ob der Befriff ausschließlich "N/A" - Werte ausgibt
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:
'SuchRichtung ermitteln
blSearchDirectionIsAscending = searchDirectionIsAscending(intCurrentTime, intMaxTime, intStartTime)
'nächsten Zeitraum für Wertsuche ermitteln
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
'Prüfen, ob id in diesem Zeitraum vorhanden ist
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
'Rechenspalten wieder löschen
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))
'Suche, ob die ID zum Zeitpunkt verfügbar ist
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))
'Wert der ID zum Zeitpunkt
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
Viele Grüße
Kai
|