Complex list lookup macro

[Engineerpete]

Hi,

I hope someone can help me out on a project I am undertaking at work that has not only got me but most of the other guys in the office stumped to the degree that we are not sure that it is possible!

To outline the problem; we have a list of individual locations which have a three or four digit ‘route’ code and a specific mileage. We need to apply to these (in a separate column) an additional number code (‘cat’) from a different list. This ‘cat’ code is based on the ‘route’ and a mileage ‘band’. I have managed to write the macro code to undertake this part of the project and it appears to work ok, however there is another more complex step in that some of the look up list codes are repeated with different mileage bands and have a different ‘cat’ number. What we need is for a macro (or formula) to go through the list and insert the lowest value available for the ‘cat’ code and mileage. The sample below should explain slightly better what we are trying to do.

Does anyone know if this is possible?

Route Mileage
ABC 123.4567
DEF 89.1011

Route Start Mile End Mile Cat
ABC 120.0099 125.1011 2
ABC 118.1000 125.1011 1
ABC 125.1011 129.0000 3
DEF 85.0000 95.0000 4
DEF 87.1500 90.1000 3

So the result would be
Route Mileage Cat
ABC 123.4567 1
DEF 89.1011 3

Code so far is as follows

Sub Macro1()

Dim i As Integer
Dim i2 As Integer
Dim tCell As String
Dim sELR As String
Dim sMileage As Double
Dim scELR As String
Dim scMileage As String

Dim done As Boolean

Dim TrackCatCell As String
Dim TrackCat As String
Dim StartCell As String
Dim StartM As Double
Dim EndCell As String
Dim EndM As Double
Dim mELR As String
Dim ELRCell As String

i = 2
i2 = 2
tCell = "N2"

For i = 2 To 4077
    TrackCat = ""
    done = False
    i2 = 2
    
    scELR = "B" & i
    Range(scELR).Select
    sELR = ActiveCell.Value

    scMileage = "D" & i
    Range(scMileage).Select
    sMileage = Val(ActiveCell.Value)

    While done = False
        ELRCell = "BL" & i2
        Range(ELRCell).Select
        mELR = ActiveCell.Value
    
        StartCell = "BN" & i2
        Range(StartCell).Select
        StartM = Val(ActiveCell.Value)
    
        EndCell = "BO" & i2
        Range(EndCell).Select
        EndM = Val(ActiveCell.Value)

        
    
        If sMileage >= StartM And sMileage <= EndM And sELR = mELR Then
            TrackCatCell = "BQ" & i2
            Range(TrackCatCell).Select
            TrackCat = ActiveCell.Value
            Debug.Print (mELR & " " & StartM & ">" & sMileage & "<" & EndM & " " & TrackCat)
            done = True
        End If
        
        
        'done = False
        
        If i2 < 8039 Then
        i2 = i2 + 1
        Else
        done = True
        End If
    Wend

    Debug.Print (sMileage & " " & sELR)
        
    tCell = "X" & i
    Range(tCell).Select
    ActiveCell.FormulaR1C1 = TrackCat
Next i



End Sub

Many thanks