求两组坐标经纬度的最小距离并匹配到位置点和距离

松野

求论坛高手帮忙：


问题：有两组坐标，求他们的最近距离，并一一匹配到结果，
两点间的距离计算公式已给出，就是球面距离的计算公式；现在的难点在于：（1）遍历单元格，用已知坐标去遍历目标坐标并计算出距离；（2）数据量大大概几十万行（如果10万行大概算100亿次）；（3）遍历后求得的距离可以放入数组（一维），难点在于取最小值并只知道最小值的小标；（4）通过小标来批到到坐标点和经纬度，距离。

zxsea_7426

你这是要在数据库的点位找到离目标最近的点坐标啊,这计算量确实有点大就这给定的数据计算量也是不小。

松野

昨晚想了以下，找到问题的解法办法了，原来我们的一维数组是可以定位下标的。我自己写了一段可供参考。

1. Sub 计算地标最近距离()
   
2. Dim i, j, n As Long
   
3. Dim arr, brr, crr, drr
   
4. Dim MinArray, MinArrayIndex As Long
   
5. arr = Sheet1.Range("d2:f" & Cells(Rows.Count, "f").End(xlUp).Row)
   
6. brr = Sheet1.Range("a2:c" & Cells(Rows.Count, "c").End(xlUp).Row)
   
7. ReDim crr(1 To UBound(brr))
   
8. ReDim drr(1 To UBound(arr), 1 To 4)
   
9. For j = 1 To UBound(arr)
   
10.     For i = 1 To UBound(brr)
    
11.         crr(i) = CalcDistance(arr(j, 3), arr(j, 2), brr(i, 3), brr(i, 2)) '调用公式，计算结果装入数组
    
12.     Next
    
13.     MinArray = Application.Min(crr) '获取距离最小值
    
14.     MinArrayIndex = Application.Match(MinArray, crr, 0) '获取最小值所在的位置（下标）
    
15.     For n = 1 To 3
    
16.         drr(j, n) = brr(MinArrayIndex, n)
    
17.     Next
    
18.     drr(j, 4) = MinArray
    
19. Next
    
20. Sheet1.Range("g2").Resize(UBound(arr), 4) = drr
    
21. End Sub
    
22. 
    
23. Function CalcDistance(ByVal lat1 As Double, ByVal lon1 As Double, ByVal lat2 As Double, ByVal lon2 As Double) As Double
    
24.     '经纬度计算距离公式，得出结果单位为米
    
25.     CalcDistance = 6378137 * 2 * Application _
    
26.     .Asin(Sqr(SumSq(Sin((Radians(lat1) - Radians(lat2)) / 2)) + Cos(Radians(lat1)) * _
    
27.     Cos(Radians(lat2)) * SumSq(Sin((Radians(lon1) - Radians(lon2)) / 2))))
    
28. End Function
    
29. Function Radians(latORlon As Double) As Double
    
30.     '度转换成弧度公式为X*π/180
    
31.     PI14 = 3.14159265358979
    
32.     Radians = latORlon * PI14 / 180
    
33. End Function
    
34. Function SumSq(xx As Double) As Double
    
35.     SumSq = xx * xx
    
36. End Function
    
37. 
    

复制代码

松野

已找到解决办法，对大批量数据计算不是很快

1. Sub 计算地标最近距离()
   
2. Dim i, j, n As Long
   
3. Dim arr, brr, crr, drr
   
4. Dim MinArray, MinArrayIndex As Long
   
5. arr = Sheet1.Range("d2:f" & Cells(Rows.Count, "f").End(xlUp).Row)
   
6. brr = Sheet1.Range("a2:c" & Cells(Rows.Count, "c").End(xlUp).Row)
   
7. ReDim crr(1 To UBound(brr))
   
8. ReDim drr(1 To UBound(arr), 1 To 4)
   
9. For j = 1 To UBound(arr)
   
10.     For i = 1 To UBound(brr)
    
11.         crr(i) = CalcDistance(arr(j, 3), arr(j, 2), brr(i, 3), brr(i, 2)) '调用公式，计算结果装入数组
    
12.     Next
    
13.     MinArray = Application.Min(crr) '获取距离最小值
    
14.     MinArrayIndex = Application.Match(MinArray, crr, 0) '获取最小值所在的位置（下标）
    
15.     For n = 1 To 3
    
16.         drr(j, n) = brr(MinArrayIndex, n)
    
17.     Next
    
18.     drr(j, 4) = MinArray
    
19. Next
    
20. Sheet1.Range("g2").Resize(UBound(arr), 4) = drr
    
21. End Sub
    
22. 
    
23. Function CalcDistance(ByVal lat1 As Double, ByVal lon1 As Double, ByVal lat2 As Double, ByVal lon2 As Double) As Double
    
24.     '经纬度计算距离公式，得出结果单位为米
    
25.     CalcDistance = 6378137 * 2 * Application _
    
26.     .Asin(Sqr(SumSq(Sin((Radians(lat1) - Radians(lat2)) / 2)) + Cos(Radians(lat1)) * _
    
27.     Cos(Radians(lat2)) * SumSq(Sin((Radians(lon1) - Radians(lon2)) / 2))))
    
28. End Function
    
29. Function Radians(latORlon As Double) As Double
    
30.     '度转换成弧度公式为X*π/180
    
31.     PI14 = 3.14159265358979
    
32.     Radians = latORlon * PI14 / 180
    
33. End Function
    
34. Function SumSq(xx As Double) As Double
    
35.     SumSq = xx * xx
    
36. End Function
    

复制代码

lxdexcel

看不明白需求

松野

当10000个坐标去匹配10000个坐标，就有点慢了，不知有没有更好的算法

liulang0808

松野 发表于 2022-12-11 23:51
当10000个坐标去匹配10000个坐标，就有点慢了，不知有没有更好的算法

是运营商还是设计院啊，还是三方的？

grf1973

不用每次都完成计算后再比大小。有没有好一点的办法，直观地比大小后，再统一计算距离。

grf1973

计算公式里用到2次 Radians(lat1)，应该只计算1次并赋值，在计算过程中直接取用。
计算公式里6378137 * 2 对于比大小没影响，可以最后用。

grf1973

考虑到经度差和纬度差都非常小，可以考虑在平面内近似。即相当于平面内两个点取最近距离，然后还原球面距离