求一个VBA ,根据经纬度求出是否在区域内。

tzjx200521

说明：表1 A2单元格是一个区域的经纬度，根据“查询表C列提供的经纬度，分析所在的经纬度是否在该区域内”

tzjx200521

1. <span style="background-color: transparent; color: inherit; font-family: Menlo, Monaco, Consolas, &quot;Courier New&quot;, monospace; font-size: inherit; white-space: pre-wrap;">def IsPtInPoly(aLon, aLat, pointList):  </span>

复制代码

   '''''     :param aLon: double 经度     :param aLat: double 纬度     :param pointList: list [(lon, lat)...] 多边形点的顺序需根据顺时针或逆时针，不能乱     '''            iSum = 0      iCount = len(pointList)            if(iCount < 3):          return False                  for i in range(iCount):                    pLon1 = pointList[0]          pLat1 = pointList[1]                    if(i == iCount - 1):                            pLon2 = pointList[0][0]              pLat2 = pointList[0][1]          else:              pLon2 = pointList[i + 1][0]              pLat2 = pointList[i + 1][1]                    if ((aLat >= pLat1) and (aLat < pLat2)) or ((aLat>=pLat2) and (aLat < pLat1)):                            if (abs(pLat1 - pLat2) > 0):                                    pLon = pLon1 - ((pLon1 - pLon2) * (pLat1 - aLat)) / (pLat1 - pLat2);                                    if(pLon < aLon):                      iSum += 1        if(iSum % 2 != 0):          return True      else:          return False  这是网上的一个代码   有没有高人帮忙改成VBA的

盼盼198310

........................

一执成念

以前搞过一个，网优的

夏天的风shh4695

请测试！
Option Explicit
Sub ggh()
Dim ws1 As Worksheet, ws2 As Worksheet, arr, k, d, i
Set d = CreateObject("scripting.dictionary")
Set ws1 = Sheets("1"): Set ws2 = Sheets("查询")
arr = Split(ws1.[a2], ";")
For i = 1 To UBound(arr)
    d(arr(i)) = ""
Next i
k = ws2.[c2]
ws2.[d2] = ""
If d.exists(k) Then
    ws2.[d2] = "是"
Else
    ws2.[d2] = "否"
End If
End Sub

tzjx200521

夏天的风shh4695 发表于 2022-3-19 19:06
请测试！
Option Explicit
Sub ggh()

给出的是边界  不是数值   你这个不对哈  不过谢谢你  

tzjx200521

一执成念 发表于 2022-3-19 18:47
以前搞过一个，网优的

有代码吗？

WangDM1991

楼主解决了吗？有思路没

yynrzwh

不知道对不对

1. Sub pd()
   
2. Dim x(1 To 9999), y(1 To 9999)
   
3. a = Sheets("1").[a2].Value
   
4. sp = Split(a, ";")
   
5. For i = 0 To UBound(sp)
   
6.     b = Split(sp(i), ",")
   
7.     n = n + 1
   
8.     x(n) = Val(b(0))
   
9.     y(n) = Val(b(1))
   
10. Next i
    
11. 东经 = WorksheetFunction.Min(x)
    
12. 西经 = WorksheetFunction.Max(x)
    
13. 北纬 = WorksheetFunction.Max(y)
    
14. 南纬 = WorksheetFunction.Min(y)
    
15. 
    
16. 
    
17. With Sheets("查询")
    
18.     lr = .Cells(Rows.Count, 3).End(3).Row
    
19.     arr = .Range("C1:D" & lr)
    
20. 
    
21.     For i = 2 To lr
    
22.         jwd = Split(arr(i, 1), ",")
    
23.         Select Case Val(jwd(0))
    
24.             Case 东经 To 西经
    
25.                 jd = 1
    
26.             Case Else
    
27.                 jd = 0
    
28.         End Select
    
29.         
    
30.         Select Case Val(jwd(1))
    
31.             Case 南纬 To 北纬
    
32.                 wd = 1
    
33.             Case Else
    
34.                 wd = 0
    
35.         End Select
    
36.         
    
37.         If jd = 1 And wd = 1 Then
    
38.             arr(i, 2) = "Y"
    
39.         Else
    
40.             arr(i, 2) = "N"
    
41.         End If
    
42.     Next i
    
43. .Range("C1:D" & lr) = arr
    
44. End With
    
45. End Sub

复制代码