Hallo,

einige Optimierungen habe ich noch durchgeführt:

Sub grossklein_Version2()
    Dim dblMin As Double
    Dim dblMax As Double
    Dim shWert1 As Worksheet
    Dim shWert2 As Worksheet
    Set shWert1 = ThisWorkbook.Sheets(1)
    Set shWert2 = ThisWorkbook.Sheets(2)
    Dim rngRow As Range
    Dim rng As Range
    Dim rngATemp As Range
    Dim rngFind As Range
    Dim iRow As Integer
    If shWert2.AutoFilterMode = False Then
        shWert2.UsedRange.Rows(1).AutoFilter
    End If
    If shWert2.FilterMode = True Then
        shWert2.ShowAllData
    End If
    For Each rngRow In shWert1.UsedRange.Rows
        Set rngATemp = rngRow.Cells(Columnindex:=6)
        If IsNumeric(rngATemp.Value) Then
            Set rngFind = shWert2.UsedRange.Columns(2)
            rngFind.AutoFilter Field:=2, Criteria1:=Replace(CDbl(rngATemp.Value), ",", ".")
            If rngFind.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
                dblMax = WorksheetFunction.Min(rngFind.Columns(1).SpecialCells(xlCellTypeVisible))
                dblMin = dblMax
                Debug.Print "Wert gefunden: "; dblMax
            Else
                ' Nächste Werte finden
                dblMax = 0
                dblMin = 0
                rngFind.AutoFilter Field:=2, Criteria1:=">" & Replace(CDbl(rngATemp.Value), ",", ".")
                dblMax = WorksheetFunction.Min(rngFind.Columns(1).SpecialCells(xlCellTypeVisible))
                rngFind.AutoFilter Field:=2, Criteria1:="<" & Replace(CDbl(rngATemp.Value), ",", ".")
                dblMin = WorksheetFunction.Max(rngFind.Columns(1).SpecialCells(xlCellTypeVisible))
                
                Debug.Print "Näherungswerte Gefunden: "; rngATemp.Value, dblMin, dblMax
            End If
        End If
    Next
    If shWert2.AutoFilterMode = True Then
        shWert2.UsedRange.Rows(1).AutoFilter
    End If

End Sub

LG, BigBen