Pairing Co-ordinates

[deusextra]

Hello forum,

I have the following problem:

I have a list of co-ordinates for the start and end point of various roads and what I need to know is which pairs of roads pass over the same co-ordinates at some point.

E.g.

Consider the following 4 road sections:

Road A: Start Point: 25000, End Point: 25200
Road B: Start Point: 25150, End Point: 25250
Road C: Start Point: 25140, End Point: 25340
Road D: Start Point: 25300, End Point: 25400

From these 4 given roads we can see that the following roads can be considered as pairs:

Road A & Road B
Road A & Road C
Road B & Road C
Road C & Road D

The problem is that I have thousands of road co-ordinates that I need to find the pairs for and manually this would take forever. I was hoping some VBA guru out there would be able to find an automated process for finding the pairs.

I have posted an excel sample file below that you can work off if you find this easier.

Any suggestions would be greatly appreciated!

Sample Excel File.xlsx

[Paul_Hossler]

pretty brute force, and could be made more efficient

I think the 'overlap' logic is correct. At least I got the answers from your example

Option Explicit
Public Const gcLength As Long = 1
Public Const gcStart As Long = 2
Public Const gcEnd As Long = 3
Public Const gcID As Long = 4
Public Const gcPairs As Long = 5

Sub LookForOverlaps()
    Dim rRoads As Range, rSort As Range
    Dim i1 As Long, i2 As Long

    'set up
    Set rRoads = ActiveWorkbook.Worksheets("Road Sections").Cells(1, 1).CurrentRegion
    Application.ScreenUpdating = False

    'sort by start
    With ActiveSheet
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=rRoads.Cells(2, gcStart).Resize(rRoads.Rows.Count - 1, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
        .Sort.SetRange rRoads
        .Sort.Header = xlYes
        .Sort.MatchCase = False
        .Sort.Orientation = xlTopToBottom
        .Sort.SortMethod = xlPinYin
        .Sort.Apply
    End With
    'do each
    With rRoads
        For i1 = 2 To .Rows.Count - 1
            Application.StatusBar = "Checking " & .Cells(i1, gcStart).Value & " (" & i1 & " out of " & .Rows.Count
            For i2 = i1 + 1 To .Rows.Count
                If pvtBetween(.Cells(i1, gcStart), .Cells(i2, gcStart), .Cells(i2, gcEnd)) Or _
                         pvtBetween(.Cells(i1, gcEnd), .Cells(i2, gcStart), .Cells(i2, gcEnd)) Or _
                         pvtBetween(.Cells(i2, gcStart), .Cells(i1, gcStart), .Cells(i1, gcEnd)) Or _
                         pvtBetween(.Cells(i2, gcEnd), .Cells(i1, gcStart), .Cells(i1, gcEnd)) Then
                    If Len(.Cells(i1, gcPairs).Value) = 0 Then
                        .Cells(i1, gcPairs).Value = .Cells(i1, gcID).Value & "+" & .Cells(i2, gcID).Value
                    Else
                        .Cells(i1, gcPairs).Value = .Cells(i1, gcPairs).Value & ", " & _
                            .Cells(i1, gcID).Value & "+" & .Cells(i2, gcID).Value
                    End If
                End If
            Next i2
        Next i1
    End With
    
    'sort by ID
    With ActiveSheet
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=rRoads.Cells(2, gcID).Resize(rRoads.Rows.Count - 1, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
        .Sort.SetRange rRoads
        .Sort.Header = xlYes
        .Sort.MatchCase = False
        .Sort.Orientation = xlTopToBottom
        .Sort.SortMethod = xlPinYin
        .Sort.Apply
    End With
    
    'cleanup
    Application.ScreenUpdating = True
    Application.StatusBar = False
End Sub

Private Function pvtBetween(X As Long, L As Long, H As Long) As Boolean
    pvtBetween = (L <= X) And (X <= H)
End Function

Paul