Consulting

Results 1 to 4 of 4

Thread: Distance between 2 locations 2D array

  1. #1

    Question Distance between 2 locations 2D array

    I have a unique identifier (column A) with its respective set of coordinates (DD units, ex. 59, -110) for 500+ locations and would like to write a macro that creates a 2D array (500+ X 500+) and automatically populates each cell within the array with the distance between all of the other coordinates in the data set.

    For example:
    __Lat Long
    A 59 -110
    B 34 -90
    C 78 -80

    Hopefully I can create an array that looks like this:

    __A B C
    A 0 X Y
    B X 0 Z
    C Y Z 0

    The formula to calculate the distance between the two coordinates is:

    =ACOS( SIN(lat1*PI()/180)*SIN(lat2*PI()/180) + COS(lat1*PI()/180)*COS(lat2*PI()/180)*COS(long2*PI()/180-long1*PI()/180) ) * 6371000

    In addition to this, if possible I would like to add a row onto the end of the array that gives the lowest distance calculated that is not zero.

    It does not have to be a macro either, I just thought this may be the fastest most efficient way to accomplish this

    Any help with this would be greatly appreciated

    Thanks in advance

  2. #2
    Moderator VBAX Sage SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,814
    Location
    All this is off the top of my head with no help from Excel VBA, so there will be errors.

    Next time, Copy a block of cells from the Sheet and paste them into your post, so we can just C&P them into a worksheet. I certainly won't look up a mess of location's Lats and Longs to make my own test data. They don't pay me.

    This formula should be the same
    Const R2D As Double = (Pi/190) 
    Constant MagicNumber as long = 637100 'Convert to... Feet? Miles? Centimeters? *Furlongs?
    
    ACOS(SIN(lat1)*SIN(lat2)*PIRN^2) +  COS(lat1)*COS(lat2)*COS(long2)*PIRN^3 _
    -long1*PIRN)*MagicNumber

    Const R2D As Double = (Pi/180) 'Declared here for speed
    Const MagicNumber as long = 637100   'Don't want to declare them 2500 times
    
    Sub MakeMatrix()
    
    Dim Originals As Variant
    Dim Distances As Variant
    Dim Results As Double
    Dim i as long, j as Long, k As long, l As long
    Dim Rws As Long
    Const Lat as Long = 1
    Const Lon As Long = 2
    Const MinDistance = 0.01 '*Furlongs ' Adjust as desired
    
    'How many Rows
    Rws = Cells(Rows,Count, "A").End(xlUp)).Row - 1 '-1 for header Row
    
    'Set up the arrays
    Originals = Application.Transpose(Range(Cells(2, "B"), Cells(Rws, "C"))).Value
    Redim Distances(1 to Rws1, 1 to Rws)
    
    'Step thru Originals one Row at a time.Twice
    For i = LBound(Originals) to Ubound(Originals)
       For j = LBound(Originals) to Ubound(Originals)
           Results = GetDistance(Lat1:=Originals(i, Lat), _
                                         Lat2 =Originals(j, Lat), _
                                         Long1:=Originals(i, Lon), _
                                         Long1:=Originals(j, Lon))
           'Step thru Distances by columns then by rows
           If Results > MinDistance Then Distances(i, j) = Results 'No zeros, so you can find the min()
                  'YOu might have to add 1 to i & j for the Distances array indices
    Next j: Next i
    
    'TBD: add Headers and Row Lables to Matrix
    'You need to Assign Top left cell of Range for Matrix
    Range("??").Resize(Rws, Rws) = Distances
    
    End Sub
    Private Function GetDistances(Lat1 As Double, Lat2 As Double, Long1 As Double, Long2 As Double) As Double
    
    GetDistances = ACOS(SIN(lat1)*SIN(lat2)*R2D^2) +  COS(lat1)*COS(lat2)*COS(long2)*R2D^3 _
    -long1*R2D)*MagicNumber
    End Function
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

  3. #3
    Thanks for the quick reply!

    Here is a few of the values, sorry didn't post them before

    Sample.xlsm

  4. #4
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    There are efficiencies that can be added, but at the expense of increasing the complexity

    Option Explicit
    
    Sub MakeMatrix()
        
        Dim rIn As Range
        Dim wsOut As Worksheet
        Dim i As Long, j As Long
        Dim Lat1 As Double, Lat2 As Double, Long1 As Double, Long2 As Double
        
        Set rIn = Worksheets("Sheet1").Cells(1, 1).CurrentRegion
        
        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets("Matrix").Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
        
        Worksheets.Add.Name = "Matrix"
        Set wsOut = Worksheets("Matrix")
        
        
        For i = 2 To rIn.Rows.Count
            wsOut.Cells(i, 1).Value = rIn.Cells(i, 1).Value
            wsOut.Cells(1, i).Value = rIn.Cells(i, 1).Value
        Next i
        
        
        For i = 2 To rIn.Rows.Count
            For j = 2 To rIn.Rows.Count
                
                Lat1 = rIn.Cells(i, 2).Value
                Long1 = rIn.Cells(i, 3).Value
                Lat2 = rIn.Cells(j, 2).Value
                Long2 = rIn.Cells(j, 3).Value
                
                If i = j Then
                    wsOut.Cells(i, j).Value = 0#
                Else
                    With Application.WorksheetFunction
                        wsOut.Cells(i, j).Value = _
                            .Acos(Sin(Lat1 * .Pi / 180) * Sin(Lat2 * .Pi / 180) + Cos(Lat1 * .Pi / 180) * Cos(Lat2 * .Pi / 180) * Cos(Long2 * .Pi / 180 - Long1 * .Pi / 180)) * 6371000
                    End With
                End If
            Next j
        Next i
    End Sub
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •