finding nearby points report

[louismullen]

Hello
I have an excel spreadsheet with 4000 different locations in the following order
column 1 location id
column 2 location easting
column 3 location northing
eg
1 450000 300000
2 500000 330000
3 4590000 345000

I need to run a macro or query to report locations that are within a specific distance of each other. e.g if I put in 20 m i need a report that 45 points are withing 20 m of each other. i need a list of these ponts.

any help please

 

[mikerickson]

What result would you want from the data sample provided?

 

[shg]

Welcome to the board.

You could enter a given location, and compute the distance to each point, and then sort and/or filter:

       ---B---- ---C--- ---D---- ---E----
   1            Easting Northing         
   2             100000   200000         
   3                                     
   4   Location Easting Northing Distance
   5         23  109320   176300    25467
   6         10    4190   363910   189858
   7         21  159710   427300   235012
   8         35  384220   239070   286893
   9         34  255780   584440   414803
  10         20  180440   704220   510596
  11         19   33980   720980   525146
  12          6  605430    22180   535798
  13          4  604750   432190   555594
  14         29  140180   756050   557500
  15          3  260990   734430   558152
  16         16  504130   594640   564856

 

[louismullen]

for example i set distance at 20 m
point number 500 could be 6 metres from point number 3950
point number 301 could be 12 metres from point number 2000

i need a complete list of points that are within 20 metres of each other.

 

[shg]

Oops, the formula in E5 and down is

=SQRT((C$2-C5)^2 + (D$2-D5)^2)

 

[shg]

Ah, gotcha. I have to scoot, but will do this later if no one else does.

That takes 16M distance calculations.

 

[louismullen]

ok when you a few minutes
thank you.

 

[shg]

       ---A---- ---B--- ---C---- ----D-----
   1   Location Easting Northing w/in Range
   2          1   52500   219300           
   3          2   53300   163200           
   4          3   53900   224500           
   5          4   61300   200700           
   6          5   64000   188300           
   7          6   65900   175100           
   8          7   67900   240300           
   9          8   70200   245400           
  10          9   70300   217400           
  11         10   72900   211300 12        
  12         11   74900   247500           
  13         12   75400   207200 10        
  14         13   84000   168700           
  15         14   86100   185400           
  16         15   87300   204300 16 17     
  17         16   89600   208100 15 17 18  
  18         17   91000   207400 15 16 18  
  19         18   92100   207100 16 17     
  20         19   93700   190800 20        
  21         20   93800   193000 19        
  22         21  100700   211500           
  23         22  105000   188300           
  24         23  105500   160600

Sub x()
    Const dMax      As Double = 5000
 
    Dim iRowA       As Long
    Dim iRowB       As Long
    Dim nRow        As Long
    Dim r           As Range
    Dim dDist       As Double
    Dim avXY        As Variant
    Dim asOut()     As String
 
    Set r = Range("B2", Cells(Rows.Count, "C").End(xlUp)).Resize(, 2)
    nRow = r.Rows.Count
    ReDim asOut(1 To nRow)
    avXY = r.Value
 
    For iRowA = 2 To nRow
        For iRowB = 2 To nRow
            If iRowA <> iRowB Then
                dDist = Sqr((avXY(iRowA, 1) - avXY(iRowB, 1)) ^ 2 + _
                            (avXY(iRowA, 2) - avXY(iRowB, 2)) ^ 2)
                If dDist <= dMax Then
                    asOut(iRowA) = asOut(iRowA) & " " & iRowB
                End If
            End If
        Next iRowB
 
        asOut(iRowA) = Trim(asOut(iRowA))
    Next iRowA
 
    With r.Offset(, 2).Resize(, 1)
        .NumberFormat = "@"
        .Value = WorksheetFunction.Transpose(asOut)
    End With
End Sub

 

[louismullen]

will try this.
thank you very much.

louis

 

[shg]

I missed a simple optimization that halves the time:

Sub x()
    Const dMax      As Double = 5000 ' change as desired
    Dim iRowA       As Long
    Dim iRowB       As Long
    Dim nRow        As Long
    Dim dDist       As Double
    Dim avdXY       As Variant
    Dim asOut()     As String
 
    With Range("B2", Cells(Rows.Count, "C").End(xlUp)).Resize(, 2)
        nRow = .Rows.Count
        ReDim asOut(1 To nRow)
        avdXY = .Value2
 
        For iRowA = 1 To nRow - 1
            For iRowB = iRowA + 1 To nRow
                If iRowA <> iRowB Then
                    dDist = Sqr((avdXY(iRowA, 1) - avdXY(iRowB, 1)) ^ 2 + _
                                (avdXY(iRowA, 2) - avdXY(iRowB, 2)) ^ 2)
 
                    If dDist <= dMax Then
                        asOut(iRowA) = asOut(iRowA) & " " & iRowB
                        asOut(iRowB) = asOut(iRowB) & " " & iRowA
                    End If
                End If
            Next iRowB
 
            asOut(iRowA) = Trim(asOut(iRowA))
        Next iRowA
 
        With .Offset(, 2).Resize(, 1)
            .NumberFormat = "@"
            .Value = WorksheetFunction.Transpose(asOut)
        End With
    End With
End Sub