1 Attachment(s)
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
Re: Find closest value in range
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