Ungefähren Wert suchen

Sub daTenKopieren()
Const paTh = "Q:\Objekt\Cleansorb Tower\Datenlog Evaluierung\Auswertungen\Tagesauswertung\"
Const datNameStart = "Auswertung "
Const logDatSp = 31
Const suchDatSp = 3 ' Spalte, in der das zu suchende Datum steht
Const firstLogRow = 3 ' erste Zeile in der Log-Datei, in der Werte stehen
Dim daTei As String
Dim zielWsh As Worksheet
Dim quellWsh As Worksheet
Dim dateNr As Long
Dim rowToCopy As Long
Dim i As Long
'1: Wert gefunden
'0: normal suchen
'-1: kann nicht gefunden werden, weil zu alt
'-2: letzte Datei geschlossen, keine Suche mehr
Dim staTe As Integer
'On Error GoTo errorHandler
daTei = Dir(paTh & datNameStart & "*")
' wenn es keine Logdateien gibt, dann gleich raus
If daTei = "" Then
MsgBox ("Keine Logdateien vorhanden!")
Exit Sub
' wenn es welche gibt, dann ScreenUpdating aus
' (dann flimmert der Bildschirm nicht)
' sowie die Zielarbeitsmappe und die erste
' Quellarbeitsmappe öffnen
Else
Application.ScreenUpdating = False
With ThisWorkbook
Set zielWsh = Worksheets.Add(, .Worksheets(.Worksheets.Count))
End With
' Wird schreibgeschützt geöffnet, zur Problemvermeidung
Set quellWsh = Workbooks.Open(paTh & daTei, , True).Worksheets(1)
End If
' Läuft über die von Dir eingetragenen Datumswerte
' ich habe mal angenommen, dass die in Zeile 2 starten
' und im ersten Sheet dieser Arbeitsmappe liegen
' ACHTUNG: Diese müssen chronologisch geordnet sein!
With ThisWorkbook.Worksheets(1)
For dateNr = 2 To .Cells(.Rows.Count, suchDatSp).End(xlUp).Row
If IsDate(.Cells(dateNr, suchDatSp)) Then
' Solange Quelldaten da und im vorigen Durchlauf kein Fehler
While staTe = 0
On Error Resume Next
rowToCopy = _
quellWsh.Columns(logDatSp).Find(.Cells(dateNr, suchDatSp)).Row
' wenn etwas gefunden, dann gibt es keinen Fehler
' also Zeile kopieren
If Err.Number = 0 Then
On Error GoTo errorHandler
quellWsh.Rows(rowToCopy).Copy zielWsh.Rows(dateNr)
staTe = 1
' Bei Fehler schauen, ob das Datum nach dem letzten Datum in der
' aktuell geöffneten Datei
Else
On Error GoTo errorHandler
' falls ja, nächste Datei öffnen, sofern vorhanden
If quellWsh.Cells(quellWsh.Rows.Count, logDatSp).End(xlUp).Value  "" Then
Set quellWsh = Workbooks.Open(paTh & daTei, , True).Worksheets(  _
_
_
_
_
_
_
1)
Else
Set quellWsh = Nothing
staTe = -2
' Hier braucht kein Fehler eingetragen werden
' passiert weiter unten automatisch
End If
' falls nein, wurde der Wert nicht gefunden
Else
staTe = -1
End If
End If
Wend
' Wenn Fehler oder letzte Datei erreicht, dann Fehlereintrag
If staTe  -2 Then staTe = 0
' Wenn es kein Datum war, dann Fehlermeldung in Zieldatei
Else
zielWsh.Cells(dateNr, 1) = _
"''" & .Cells(dateNr, suchDatSp).Text & "' ist kein Datum!"
End If
Next
End With
' Wenn noch eine Quelldatei offen ist (state > -2), dann diese jetzt zu
If staTe > -2 Then quellWsh.Parent.Close False
' ScreenUpdating wieder ein
Application.ScreenUpdating = True
Exit Sub
endOnError:
On Error Resume Next
' Quelldatei zu
quellWsh.Parent.Close False
' Alles was an Applikationseinstellungen geändert wurde wieder zurück
Application.ScreenUpdating = True
Application.DisplayAlerts = True
' Fehlermeldung - ist jetzt nicht sonderlich schön gemacht,
' aber das richtig zu machen ist ein großer Aufwand
MsgBox ("Fehler aufgetreten bei Zeile " & dateNr & " und Datei '" & daTei & "'!" & _
vbNewLine & _
"Fehlermeldung: " & Err.Number & " - " & Err.Description)
Exit Sub
' Muss ich so machen, damit das On Error Resume Next bei endOnError funktioniert
errorHandler:
Resume endOnError
End Sub