从点数据源找出与已经点距离最近点

亲亲小布布

目的：1.通过AB两列横纵坐标去源数据（H到J列）中找到与之距离最近的点，然后将对应J列的数据写入C列；2.通过DE两列横纵坐标去源数据（H到J列）中找到与之距离最近的点，然后将对应J列的数据写入F列

问题：1.自己在附件中写了代码，但是不知道怎么循环得出那个最小值，只是按照常规的二维数组循环，用的勾股定理求出两点距离，然后用小于50作为判断条件，可能不是精确，并没有找到与之距离最近的那个点。2.按照我的代码，结果输出C、H两列中间会有空单元格，说明程序并没有找到一个匹配条件的点，这个不太可能，因为我的源数据点范围是包含了目的点的，应该总有一个最近的点存在才对。望指教！

说明：1.文件大小超限制，分了三个包！2.源数据有22万行

1. Sub TEST()
   
2.    
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     With Sheet1
   
6.         .Range("C2:C99999") = ""
   
7.         .Range("F2:F99999") = ""
   
8.         ar = .Range("a1").CurrentRegion
   
9.         br = .Range("H1").CurrentRegion
   
10.         'ReDim cr(1 To UBound(ar))
    
11.         'ReDim dr(1 To UBound(ar))
    
12.         For i = 2 To UBound(ar)
    
13.             For x = 2 To UBound(br)
    
14.                 If WorksheetFunction.SumSq(Abs(br(x, 1) - ar(i, 1)), Abs(br(x, 2) - ar(i, 2))) <= 50 Then 'sumsq求平方和
    
15.                     Cells(i, 3) = Round(br(x, 3), 1)
    
16.                 ElseIf WorksheetFunction.SumSq(Abs(br(x, 1) - ar(i, 4)), Abs(br(x, 2) - ar(i, 5))) <= 50 Then
    
17.                     Cells(i, 6) = Round(br(x, 3), 1)
    
18.                 End If
    
19.             Next x
    
20.             
    
21.         Next i
    
22.         '        .Range("g2").Resize(UBound(cr), 1) = cr
    
23.         '        .Range("j2").Resize(UBound(dr), 1) = dr
    
24.         
    
25.     End With
    
26.     Application.ScreenUpdating = True
    
27.     Application.DisplayAlerts = True
    
28. End Sub

复制代码

dto8323

你这个代码真是一言难尽...
1、ar只有两列，代码里的ar(i,4)应该会报错
2、计算两列的代码为什么要放到一个if逻辑里？这样子写AB列和DE列只能填入一边
3、cr和dr从头到尾没赋值，又写进表格里干什么？而且很有可能还会错行

亲亲小布布

dto8323 发表于 2024-1-12 13:59
你这个代码真是一言难尽...
1、ar只有两列，代码里的ar(i,4)应该会报错
2、计算两列的代码为什么要放到一 ...

ar(i,4)是数组里的元素不会报错，放在一个if里是因为总能找到一个最近的点，两列都能写入，cr和dr本来打算用数组方式resiza，结果发现i的值会跳跃，就是说中间的某些行可能在源数据找不到，这应该不可能，但是找不到原因

ykcbf1100

亲亲小布布 发表于 2024-1-12 14:20
ar(i,4)是数组里的元素不会报错，放在一个if里是因为总能找到一个最近的点，两列都能写入，cr和dr本来打 ...

ar数组只有2列，你ar(i,4)会不报错？

大灰狼1976

不会报错的吧，ar = .Range("a1").CurrentRegion是到F列的，因为第一行有标题。

dto8323

亲亲小布布 发表于 2024-1-12 14:20
ar(i,4)是数组里的元素不会报错，放在一个if里是因为总能找到一个最近的点，两列都能写入，cr和dr本来打 ...

ar确实不会报错，是从第一行开始读的，这里是我看漏了。
但你那个x的循环并没有筛选最小值的功能：
1.假如已经写入一个距离为0的点的Z值，之后也会被另一个距离小于50的点的Z值覆盖掉；
2.如果所有距DE列的点距离小于50的源数据点与AB列的点距离也小于50，那么这个if循环根本就不会跳转到DE列的代码，而是会全部写到AB列就结束，也就是说DE列会出现空值；
3.按你的代码，如果确实在源数据中存在目标点，至少C列应该不会是空的，建议将50的限制改大一点再看看，例如10000。如果改大之后C列就齐活了，那就说明源数据中的确是不存在距离50以下的点。

另外，22万行直接用遍历来写速度会可以预见的慢，优化一下距离算法至少可以提升30倍以上的速度，这个是有实例的。

亲亲小布布

dto8323 发表于 2024-1-13 10:46
ar确实不会报错，是从第一行开始读的，这里是我看漏了。
但你那个x的循环并没有筛选最小值的功能：
1. ...

感谢指教，我找找相关算法优化

dto8323

亲亲小布布 发表于 2024-1-15 09:02
感谢指教，我找找相关算法优化

https://club.excelhome.net/forum ... amp;_dsign=0194df8d
5楼有算法，你可以看看

yynrzwh

1. Sub test()
   
2. 
   
3. lr = Cells(Rows.Count, 1).End(3).Row
   
4. Range("c2:c" & lr) = ""
   
5. Range("f2:f" & lr) = ""
   
6. ar = Range("a1").CurrentRegion
   
7. br = Range("h1").CurrentRegion
   
8.     For i = 2 To UBound(ar)
   
9.         For j = 1 To 6 Step 3
   
10.             tem = 10 ^ 10: r = 0
    
11.             For x = 2 To UBound(br)
    
12.                 s1 = Abs(br(x, 1) - ar(i, j)) 'X差值
    
13.                 s2 = Abs(br(x, 2) - ar(i, j + 1)) 'Y差值
    
14.                 s = VBA.Sqr(s1 ^ 2 + s2 ^ 2) '差值平方和的平方根
    
15.                 If s < tem Then tem = s: r = x '获得最小值
    
16.             Next x
    
17.             If r > 0 Then ar(i, j + 2) = br(r, 3)
    
18.         Next j
    
19.     Next i
    
20. Range("a1").CurrentRegion = ar
    
21. End Sub
    

复制代码

计算距离的公式我不懂，这是根据你的意思写的。
平方和是一个很大的数字，开始几个都是10 的9次方以上。
按勾股定理的话，是不是应该取平方根？
不过并不影响取最小值。