Расстояние между двумя координатами 2D массива - PullRequest
Новая
       19

Расстояние между двумя координатами 2D массива

0 голосов
/ 07 мая 2018

У меня есть уникальный идентификатор (столбец A) с соответствующим набором координат (DD-единицы, например 59, -110) для 500+ мест и я хотел бы написать макрос, который создает 2D-массив (500+ X 500+) и автоматически заполняет каждую ячейку в массиве расстоянием между всеми другими координатами в наборе данных.

Пример набора данных (начиная с A1): 

ID       Lat  Long    
A        59   -110    
B        58   -105    
C        62   -103

Надеюсь, я могу создать массив, который выглядит следующим образом: 

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

Формула для расчета расстояниямежду двумя координатами: 

=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

В дополнение к этому, если возможно, я хотел бы добавить строку в конец массива, которая дает самое низкое вычисленное расстояние, которое не равно нулю.

Это то, что у меня пока есть: 

Const R2D As Double = (3.1459 / 180) 
Const MagicNumber As Long = 637100  
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



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


Rws = Cells(Rows, Count, "A").End(xlUp).Row - 1


Originals = Application.Transpose(Range(Cells(2, "B"), Cells(Rws, "C"))).Value
ReDim Distances(1 To Rws1, 1 To Rws)


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))


   If Results > MinDistance Then Distances(i, j) = Results

 Next j: Next i


Range("F1").Resize(Rws, Rws) = Distances

End Sub

Любая помощь с этим будет принята с благодарностью

Новое в стеке, так что если есть какая-либо дополнительная информация, пожалуйста, спросите

Заранее спасибо

1 Ответ

0 голосов
/ 07 мая 2018

У меня была проблема с неработающей функцией Acos, поэтому я сделал это по-своему, с нуля и следуя найденной формуле здесь

Расстояние = (Грех ((Me.TxtEndLat * 3.14159265358979) / 180)) * (Грех ((Me.TxtStartLat * _ 3.14159265358979) / 180)) + (Cos ((Me.TxtEndLat * 3.14159265358979) / 180)) * _ ((Cos ((Me.TxtStartLat * 3.14159265358979) / 180))) * _ (Cos ((Me.TxtStartLong - Me.TxtEndLong) * (3.14159265358979 / 180)))

Расстояние = 6371 * (Atn (-Distance / Sqr (-Distance * Distance + 1)) + 2 * Atn (1))

Он принимает данные в Sheet1 и выводит матрицу в Sheet2

Option Explicit

Sub test()

    Dim sheetSource As Worksheet
    Dim sheetResults As Worksheet

    Dim intPos As Long
    Dim intMax As Long

    Dim i As Long
    Dim j As Long
    Dim strID As String

    Dim dblDistance As Double
    Dim dblTemp As Double

    Dim Lat1 As Double 
    Dim Lat2 As Double 
    Dim Long1 As Double 
    Dim Long2 As Double 

    Const PI As Double = 3.14159265358979

    Set sheetSource = ThisWorkbook.Sheets("Sheet1")
    Set sheetResults = ThisWorkbook.Sheets("Sheet2")

    intPos = 1

    ' 1 Build the matrix
    For i = 2 To sheetSource.Rows.Count

        strID = Trim(sheetSource.Cells(i, 1))

        If strID = "" Then Exit For

        intPos = intPos + 1

        sheetResults.Cells(intPos, 1) = strID
        sheetResults.Cells(1, intPos) = strID

    Next i

    intMax = intPos


    If intMax = 1 Then Exit Sub ' no data


    ' 2 : compute matrix
    For i = 2 To intMax 'looping on lines

        Lat1 = sheetSource.Cells(i, 2)
        Long1 = sheetSource.Cells(i, 3)

        For j = 2 To intMax 'looping on columns

            Lat2 = sheetSource.Cells(j, 2)
            Long2 = sheetSource.Cells(j, 3)

            ' Some hard trigonometry over here
            dblTemp = (Sin((Lat2 * PI) / 180)) * (Sin((Lat1 * PI) / 180)) + (Cos((Lat2 * PI) / 180)) * _
                      ((Cos((Lat1 * PI) / 180))) * (Cos((Long1 - Long2) * (PI / 180)))


            If dblTemp = 1 Then ' If 1, the 2 points are the same. Avoid a division by zero
                 sheetResults.Cells(i, j) = 0
            else
                 dblDistance = 6371 * (Atn(-dblTemp / Sqr(-dblTemp * dblTemp + 1)) + 2 * Atn(1))
                 sheetResults.Cells(i, j) = dblDistance
            End If

        Next j
    Next i


End Sub

Результаты: 

        A             B             C           
A   0             310,9566251   507,6414335
B   310,9566251   0             458,4126121
C   507,6414335   458,4126121   0

Быстрый тест здесь между A и B показывает, что результат почти идентичен: сайт дает 310.94 KM, а моя функция дает 310,9566251, что составляет разницу +/- 15 см. , Более 300 км, это приемлемо.

Таким образом, я могу с уверенностью предположить, что это работает.

Теперь вы можете настроить его;)

...