Find closest value in range

My code loops through lots of blocks of data that are separated with a 'd' (see attachment).

The code loops through each block of data between the d's perfectly.

But I can't get it to search each block - the code in red won't work no matter how I change it.

What it should do is search the values in column D and find the one that's closest to the value in column N. Once it's done that, an X should appear in the same row in Column F - as per the bottom 2.

My code is here:

Code:

---


Sub subd()

    Columns("F:N").Select
    Selection.ClearContents
 
    Dim rngFind As Range
    Dim strValueToPick As String
    Dim rngLook As Range
    Dim strFirstAddress As String
    Dim topRow As Long
    Dim botRow As Long
    Dim count As Integer
    Dim W As Integer
   
    Set rngLook = Range("B1:B" & Cells(Rows.count, "B").End(xlUp).Row)
    strValueToPick = "d"
    With rngLook
        Set rngFind = .Find(strValueToPick, LookIn:=xlValues, LookAt:=xlWhole)
        If Not rngFind Is Nothing Then
            strFirstAddress = rngFind.Address
            Do
                topRow = rngFind.Row
                Set rngFind = .FindNext(rngFind)
                botRow = rngFind.Row - 1
                If botRow - topRow > 1 Then

count = botRow - topRow
W = (count * (Range("D" & topRow + 1).Value)) / WorksheetFunction.Pi
Range("D" & topRow + 1).Offset(0, 10).Value = W


If Range("D" & topRow + 1).Offset(3, 0).Value < 20 Then

' +++++++++++++++++++++++++

    Dim d As Double, i As Long, j As Long
    Dim LR As Long, x
    d = 1000
    LR = botRow - topRow
   
    x = Range("D" & topRow + 1).Offset(0, 10).Value

    For i = 1 To LR + 1
        If Range("D" & i).Value = "" Then
            d = 1000
            x = Range("N" & i + 1).Value
            Range("f" & j).Value = "X"
        Else
            If Abs(Range("D" & i).Value - x) < d Then
                j = i
                d = Abs(Range("D" & i).Value - x)
            End If
        End If
    Next i

' +++++++++++++++++++++++++

Else
Range("D" & topRow + 1).Offset(2, 2).Value = "b1"
End If
        End If
            Loop While Not rngFind Is Nothing And rngFind.Address <> strFirstAddress
        End If
    End With

End Sub

---

try this:

vb Code:

Sub subd()
 
    Range("B1:B" & Cells(Rows.count, "B").End(xlUp).Row).Select
    
    Dim start_endRows() As Integer
    ReDim Preserve start_endRows(0)
    start_endRows(0) = 1
    
    Selection.Find(What:="d", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
            xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
            False, SearchFormat:=False).Activate
    
    ReDim Preserve start_endRows(UBound(start_endRows) + 1)
    
    start_endRows(UBound(start_endRows)) = ActiveCell.Row
    
    If start_endRows(UBound(start_endRows)) = start_endRows(UBound(start_endRows) - 1) Then Exit Sub
    
    Do
        ReDim Preserve start_endRows(UBound(start_endRows) + 1)
        Selection.FindNext(After:=ActiveCell).Activate
        start_endRows(UBound(start_endRows)) = ActiveCell.Row
        
        If start_endRows(UBound(start_endRows)) < start_endRows(UBound(start_endRows) - 1) Then
            ReDim Preserve start_endRows(UBound(start_endRows) - 1)
            Exit Do
        End If
    
    Loop
    
    For x = 0 To UBound(start_endRows) - 1
    
        Dim findValue As Integer
        findValue = Cells(start_endRows(x) + 1, 14).Value
        
        Dim closest As Integer
        closest = -1
        
        Dim difference As Double
        difference = 65536
        
        For r = start_endRows(x) + 1 To start_endRows(x + 1) - 1
           If Abs(Cells(r, 4).Value - findValue) < difference Then
            difference = Abs(Cells(r, 4).Value - findValue)
            closest = r
           End If
        Next
        
        If findValue <> 0 Then
            Cells(closest, 6).Value = "X"
        End If
    
    Next
 
End Sub