Looping Macro on find closest match

[Capt_Antihero]

Hello,

I have modified some code I found in these forums that once I enter a value in a cell I can have it find the closest match to that value and scroll down the list and paste that value as an offset. The code works perfectly, but my data will often contain the same values repeated and these aren't duplicates and I need to know how to loop the code to ensure it doesn't just find the first value but also the second (if the first is already populated) Code is:

Sub findclose()
Dim rng As Range, Dn As Range, Mx As Single, oAd As String
Dim num As Range

Set num = ActiveSheet.Range("B1")


Set rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
Mx = Application.Max(rng)
For Each Dn In rng
If Abs(num - Dn) < Mx Then
Mx = Abs(num - Dn)
oAd = Dn.Address


End If
Next Dn


Range(oAd).Offset(, 2) = ActiveSheet.Range("B1").Value


---- What I need to do is insert a loop of some sort that basically says IF my offset cell has a value then to find the next closest amount and continue the macro.

So if my list was:

700
50
500
600
500

And I wanted to find 499 then my list would look like:

700
50
500 499
600
500

BUT if I wanted to match off another amount of 501 it would keep the 499 it found and then find the 501 making the completed list look like:

700
50
500 499
600
500 501

Right now the amounts are being overidden as I don't know how to loop it... Please help if you can...?

James.

 

[brian.wethington]

Sub findclose()
Dim rng As Range, Dn As Range, Mx As Single, oAd As Range, X As Double
Dim num As Range

Set num = ActiveSheet.Range("B1")
Set rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
Mx = Application.Max(rng)
For Each Dn In rng
    If Abs(num - Dn) < Mx Then
        Mx = Abs(num - Dn)
        Set oAd = Dn
    End If
Next Dn
Mx = WorksheetFunction.CountIf(rng, oAd.Value)
Set Dn = oAd
For X = 1 To Mx + 1
    If Len(Dn.Offset(, 2).Value) = 0 Then
        Dn.Offset(, 2).Value = Range("B1")
        Exit Sub
    Else
        If X > Mx Then MsgBox ("All instances were covered")
        Set Dn = rng.Find(oAd.Value, Dn, , , xlNext)
    End If
Next X
End Sub

Something like this perhaps.

 

[Capt_Antihero]

Thanx Brian but I get Run Time error 91 variable not set when I try to search for the second $50 debug highlights If Len(Dn.Offset(, 2).Value) = 0 Then....?

 

[mikerickson]

If you have shorter list and have already found 499
700
50
500 499
600

and are looking for 501, what do you want, do you want to overwrite the 500 499 or do you want to find 600 (the closest of the not matched values)?

 

[Capt_Antihero]

Based on the example you provided I would want to find 600 being the closest of the not matched values

 

[brian.wethington]

Something like this work better?

Sub findclose()
Dim rng As Range, Dn As Range, Mx As Long, oAd As Range, X As Long, num As Range

Set num = ActiveSheet.Range("B1")
Set rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
X = 0
Mx = Application.Max(rng)
For Each Dn In rng
    Select Case Abs(num - Dn.Value)
        Case Is < Mx
            Mx = Abs(num - Dn.Value)
            Set rng = Nothing
            Set rng = Dn
        Case Mx
            Set rng = Union(rng, Dn)
    End Select
Next
Debug.Print rng.Address

For Each Dn In rng
    If Len(Dn.Offset(, 2).Value) = 0 Then
        Dn.Offset(, 2).Value = Range("B1")
        X = 1
        Exit Sub
    End If
Next
MsgBox "All instances covered", , "No Slot"
End Sub

mikerickson, that is actually a good question. I assumed something I probably shouldn't; that he didn't want to overwrite or do anything with the value (clearly a poor assumption on my part due to his prior comment, and thus my code is clearly not exactly his intentions. I must go for now though). As far as your error, I think it is tied to the find functionality and dollars, which I was unaware of the dollars.

 

[Capt_Antihero]

Looks like we have a winner here guys, so far testing is proving successful - I think we can call this one solved THANK YOU SO MUCH