请教高手，这段代码还如何再提速？

mishangu

目前我这段代码，单行比对5万多行，计算时间大部分都在9秒左右，有点慢。

请教高手，还有提速的可能么？



Option Explicit
Sub test()

Dim i&, n&, r&, Arr, arr1, t
t = Timer

Application.ScreenUpdating = False
ActiveSheet.Range("$A$1:$H$100000").AutoFilter Field:=8
r = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Sheet1").Range("H2:H" & r).ClearContents
Arr = Sheets("Sheet1").Range("e2:f" & r)
ReDim arr1(1 To UBound(Arr), 1 To 1)
r = r - 1
For i = 1 To r
   
    n = i
               
               arr1(n, 1) = jl(Range("J1"), Range("K1"), Arr(i, 1), Arr(i, 2))
         
         If arr1(n, 1) > Range("M1") Then
         arr1(n, 1) = ""
         
         Else
          [H2].Resize(UBound(Arr), 1) = arr1
         
          End If
     Next i
     
     
     ActiveSheet.Range("$A$1:$H$100000").AutoFilter Field:=8, Criteria1:="<>"
     
     
     
Application.ScreenUpdating = True
'MsgBox "总运行时间为" & Timer - t

End Sub
Function jl(x1, y1, x2, y2)
jl = 6378137 * 2 * Application.Asin(Sqr(Application.SumSq(Sin((Application.Radians(y1) - Application.Radians(y2)) / 2)) + Cos(Application.Radians(y1)) * Cos(Application.Radians(y2)) * Application.SumSq(Sin((Application.Radians(x1) - Application.Radians(x2)) / 2))))
End Function

我是来讨说法的

附件呢附件呢

mishangu

谢谢各位高手，现在补充附件，麻烦再给看看如何提高速度，不胜感激！

mishangu

我是来讨说法的 发表于 2018-8-9 11:07
附件呢附件呢

谢谢各位高手，现在补充附件，麻烦再给看看如何提高速度，不胜感激！

mishangu

我是来讨说法的 发表于 2018-8-9 11:07
附件呢附件呢

附件来了，传了两次都超过了2MB，删除了部分。

我是来讨说法的

五万行，2.5秒
我觉得你的算距离的公式还可以简化

1. Sub test()
   
2. Dim T
   
3. Dim arr As Variant
   
4. Dim result As Variant
   
5. Dim i As Long
   
6. Dim k1 As Double
   
7. Dim k2 As Double
   
8. Dim L As Double, j As Integer, n As Long
   
9. Dim tar As Double
   
10. T = Timer
    
11. 
    
12. r = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    
13. Sheets("Sheet1").Range("H2:H" & r).ClearContents
    
14. 
    
15. arr = Sheets("Sheet1").Range("A2:H" & r)
    
16. ReDim result(1 To r, 1 To 8)
    
17. 
    
18. k1 = Range("J1")
    
19. k2 = Range("K1")
    
20. tar = Range("M1")
    
21. n = 0
    
22. For i = 1 To UBound(arr)
    
23.     L = jl(k1, k2, arr(i, 5), arr(i, 6))
    
24.     If L <= 500 Then
    
25.         n = n + 1
    
26.         For j = 1 To 7
    
27.             result(n, j) = arr(i, j)
    
28.         Next
    
29.         result(n, 8) = L
    
30.     End If
    
31. Next
    
32. Range("I2").Resize(n, 8) = result
    
33. MsgBox "总运行时间为" & Timer - T
    
34. 
    
35. End Sub
    
36. 
    
37. Function jl(x1, y1, x2, y2)
    
38. jl = 6378137 * 2 * Application.Asin(Sqr(Application.SumSq(Sin((Application.Radians(y1) - Application.Radians(y2)) / 2)) + Cos(Application.Radians(y1)) * Cos(Application.Radians(y2)) * Application.SumSq(Sin((Application.Radians(x1) - Application.Radians(x2)) / 2))))
    
39. End Function

复制代码

zopey

sql 查询中使用自定义距离函数，总报错 显示“函数未定义“ ，
只好循环逐条处理。

指定距离查询.zip (1.91 MB, 下载次数: 4)

2018-8-9 16:55 上传

点击文件名下载附件

fxl447098457

zopey 发表于 2018-8-9 16:59
sql 查询中使用自定义距离函数，总报错 显示“函数未定义“ ，
只好循环逐条处理。

excel里面玩不了的、我以前也提过这个问题。。。。