PDA

View Full Version : Pairing Co-ordinates



deusextra
08-02-2013, 03:31 AM
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!

10357

Paul_Hossler
08-02-2013, 08:22 AM
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