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

grf1973

这样计算时间节省到1/4，还是很有效的。

松野

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

这个算出来结果不一样

leolee82

for循环和CalcDistance把application优化掉。For i = 1 To UBound(brr)中就可以把最小值 和索引算出来，crr没啥用。把CalcDistance代码合并到循环中可以减少参数传递和转换。CalcDistance中的常量可以在找到最小值后再乘。arr,brr也可以先转换成double数组。优化一下应该能快很多。

grf1973

松野 发表于 2022-12-12 21:41
这个算出来结果不一样

嗯，细看了一下，数据源861条，正确的有829条。

grf1973

小改了一下，略有提高，可以忽略不计。
常量后置影响更小。

lxdexcel

1. Sub js()
   
2. Dim i, j As Long
   
3. Dim arr, brr, crr, drr
   
4. 
   
5. Dim t As Double
   
6. Dim d1 As Double
   
7. Dim d2 As Double
   
8. Dim d3 As Double
   
9. 
   
10. Dim td As Double
    
11. Dim d As Double
    
12. Dim twc As Double
    
13. 
    
14. Dim imin As Long
    
15. arr = Sheet1.Range("d2:f" & Cells(Rows.Count, "f").End(xlUp).Row)
    
16. brr = Sheet1.Range("a2:c" & Cells(Rows.Count, "c").End(xlUp).Row)
    
17. t = Timer
    
18. 
    
19. ReDim crr(1 To UBound(brr), 1 To 3)
    
20. ReDim drr(1 To UBound(arr), 1 To 4)
    
21. For i = 1 To UBound(brr)
    
22.    twc = Cos(Radians(brr(i, 3)))
    
23.   
    
24.    crr(i, 1) = twc * Cos(Radians(brr(i, 2)))
    
25.    crr(i, 2) = twc * Sin(Radians(brr(i, 2)))
    
26.    
    
27.    crr(i, 3) = Sin(Radians(brr(i, 3)))
    
28. Next
    
29. For j = 1 To UBound(arr)
    
30.    twc = Cos(Radians(arr(j, 3)))
    
31.   
    
32.     d1 = twc * Cos(Radians(arr(j, 2)))
    
33.     d2 = twc * Sin(Radians(arr(j, 2)))
    
34.    
    
35.     d3 = Sin(Radians(arr(j, 3)))
    
36.     d = (d1 - crr(1, 1)) * (d1 - crr(1, 1)) + (d2 - crr(1, 2)) * (d2 - crr(1, 2)) + (d3 - crr(1, 3)) * (d3 - crr(1, 3))
    
37.     imin = 1
    
38.    
    
39.     For i = 2 To UBound(crr)
    
40.       
    
41.         td = (d1 - crr(i, 1)) * (d1 - crr(i, 1)) + (d2 - crr(i, 2)) * (d2 - crr(i, 2)) + (d3 - crr(i, 3)) * (d3 - crr(i, 3))
    
42.         
    
43.         If td < d Then
    
44.            d = td
    
45.            imin = i
    
46.         End If
    
47.         
    
48.     Next
    
49.    
    
50.     drr(j, 1) = brr(imin, 1)
    
51.    
    
52.      drr(j, 2) = brr(imin, 2)
    
53.     drr(j, 3) = brr(imin, 3)
    
54.     'drr(j, 4) = CalcDistance(brr(imin, 3), brr(imin, 2), arr(j, 3), arr(j, 2))
    
55.     drr(j, 4) = 6378137 * 2 * Application.Asin(Sqr(d) / 2)
    
56. Next
    
57. Sheet1.Range("o2").Resize(UBound(arr), 4) = drr
    
58. Sheet1.Range("s1") = Timer - t
    
59. 
    
60.    
    
61. End Sub

复制代码

基于计算的优化，如果数据量很大，运算速度达不到要求，就要选择其他方法了

lxdexcel

Sub js()
Dim i, j As Long
Dim arr, brr, crr, drr

Dim t As Double
Dim d1 As Double
Dim d2 As Double
Dim d3 As Double

Dim td As Double
Dim d As Double
Dim twc As Double

Dim imin As Long
arr = Sheet1.Range("d2:f" & Cells(Rows.Count, "f").End(xlUp).Row)
brr = Sheet1.Range("a2:c" & Cells(Rows.Count, "c").End(xlUp).Row)
t = Timer

ReDim crr(1 To UBound(brr), 1 To 3)
ReDim drr(1 To UBound(arr), 1 To 4)
For i = 1 To UBound(brr)
   twc = Cos(Radians(brr(i, 3)))
  
   crr(i, 1) = twc * Cos(Radians(brr(i, 2)))
   crr(i, 2) = twc * Sin(Radians(brr(i, 2)))
   
   crr(i, 3) = Sin(Radians(brr(i, 3)))
Next
For j = 1 To UBound(arr)
   twc = Cos(Radians(arr(j, 3)))
  
    d1 = twc * Cos(Radians(arr(j, 2)))
    d2 = twc * Sin(Radians(arr(j, 2)))
   
    d3 = Sin(Radians(arr(j, 3)))
    d = (d1 - crr(1, 1)) * (d1 - crr(1, 1)) + (d2 - crr(1, 2)) * (d2 - crr(1, 2)) + (d3 - crr(1, 3)) * (d3 - crr(1, 3))
    imin = 1
   
    For i = 2 To UBound(crr)
      
        td = (d1 - crr(i, 1)) * (d1 - crr(i, 1)) + (d2 - crr(i, 2)) * (d2 - crr(i, 2)) + (d3 - crr(i, 3)) * (d3 - crr(i, 3))
        
        If td < d Then
           d = td
           imin = i
        End If
        
    Next
   
    drr(j, 1) = brr(imin, 1)
   
     drr(j, 2) = brr(imin, 2)
    drr(j, 3) = brr(imin, 3)
    'drr(j, 4) = CalcDistance(brr(imin, 3), brr(imin, 2), arr(j, 3), arr(j, 2))
    drr(j, 4) = 6378137 * 2 * Application.Asin(Sqr(d) / 2)
Next
Sheet1.Range("o2").Resize(UBound(arr), 4) = drr
Sheet1.Range("s1") = Timer - t

   
End Sub

松野

lxdexcel 发表于 2022-12-14 09:24
基于计算的优化，如果数据量很大，运算速度达不到要求，就要选择其他方法了

这个优化后速度很快，1万匹配1万条数据（1亿次循环）测试结果比原来快了11倍；距离结果值的小数点后10位不一样，不过已经不影响了，在我的电脑上运行需要把Radians替换为worksheetfunction.Radians，不然会报错，可能是我的模块里面自定义了Radians函数。

松野

我把最终的结果分享出来并加入了进度条，测试数据为5000条匹配5000条，可以很明显看出来算法3速度快好几倍

leolee82

这样弄弄会更快一点，主要是减少For i = 2 To UBound(crr)中的计算量
Sub js3()
Dim i, j As Long
Dim arr, brr, crr, drr

Dim t As Double
Dim d1 As Double
Dim d2 As Double
Dim d3 As Double

Dim td As Double
Dim d As Double
Dim twc As Double

Dim imin As Long
Dim w As Double
Dim ZDK As Integer
tm = Timer
'''''''''''''进度条'''''''''''''''''''''''
'UserForm1.Show 0
'ZDK = UserForm1.TextBox1.Width
'UserForm1.TextBox2.SetFocus '焦点设置在文本框2防止闪烁
'''''''''''''进度条'''''''''''''''''''''''
arr = Sheet1.Range("d2:f" & Cells(Rows.Count, "f").End(xlUp).Row)
brr = Sheet1.Range("a2:c" & Cells(Rows.Count, "c").End(xlUp).Row)
t = Timer

ReDim crr(1 To UBound(brr), 1 To 3) As Double
ReDim drr(1 To UBound(arr), 1 To 4)

Dim b2 As Double, b3 As Double
For i = 1 To UBound(brr)
   
    b2 = brr(i, 3) * PI
    b3 = brr(i, 3) * PI
   twc = Cos(b3)
   

   crr(i, 1) = twc * Cos(b2)
   crr(i, 2) = twc * Sin(b2)
   
   crr(i, 3) = Sin(b3)
Next

Dim a2 As Double, a3 As Double, x As Double, y As Double, z As Double, iubc As Long, iuba As Long, p As Long, p0 As Double
iuba = UBound(arr)
iubc = UBound(crr)
p0 = 100 / iuba
For j = 1 To iuba
    a2 = arr(j, 2) * PI
    a3 = arr(j, 3) * PI
   
    twc = Cos(a3)
    d1 = twc * Cos(a2)
    d2 = twc * Sin(a2)
    d3 = Sin(a3)
   
    x = d1 - crr(1, 1)
    y = d2 - crr(1, 2)
    z = d3 - crr(1, 3)
    d = x * x + y * y + z * z
    imin = 1
   
   
    For i = 2 To iubc
         x = d1 - crr(i, 1)
         y = d2 - crr(i, 2)
         z = d3 - crr(i, 3)
         
        td = x * x + y * y + z * z

        If td < d Then
           d = td
           imin = i
        End If
    Next
   
    drr(j, 1) = brr(imin, 1)
   
     drr(j, 2) = brr(imin, 2)
    drr(j, 3) = brr(imin, 3)
    'drr(j, 4) = CalcDistance(brr(imin, 3), brr(imin, 2), arr(j, 3), arr(j, 2))
    drr(j, 4) = 6378137 * 2 * Application.Asin(Sqr(d) * 0.5)
'''''''''''进度条''''''''''''''''''''''
   
'    If j * p0 > p + 5 Then
'        p = j * p0
'        UserForm1.Label1.Width = ZDK * p / 100
'        UserForm1.Label2.Caption = p & "%"
        DoEvents
'    End If
'''''''''''进度条''''''''''''''''''''''
Next
Sheet1.Range("g2").Resize(UBound(arr), 4) = drr
Unload UserForm1
MsgBox "恭喜，计算完成" & "，耗时：" & Timer - tm, vbOKOnly Or 64, "提示"
End Sub