VBA 行政区划四级下拉菜单

NoooEnd

1. Function selectList(stage)
   
2.     Dim areaList As Object
   
3.     Set areaList = CreateObject("scripting.dictionary")
   
4.     Dim tier1, tier2
   
5.     Dim tier2s(), region
   
6.     Dim rowNum
   
7.     rowNum = ThisWorkbook.Worksheets(1).UsedRange.Rows.Count
   
8.     region = ThisWorkbook.Worksheets(1).Range("A2:D" & rowNum)
   
9.     Select Case stage
   
10.         Case "省"
    
11.             col = "1"
    
12.         Case "市"
    
13.             col = "2"
    
14.         Case "县"
    
15.             col = "3"
    
16.     End Select
    
17.     For i = 1 To UBound(region)
    
18.         tier1 = region(i, col)
    
19.         tier2 = region(i, col + 1)
    
20.         If Not areaList.exists(tier1) Then
    
21.             ReDim tier2s(1 To 1)
    
22.             tier2s(1) = tier2
    
23.             areaList.Add tier1, tier2s()
    
24.         Else
    
25.             tier2s() = areaList(tier1)
    
26.             If UBound(VBA.Filter(tier2s(), tier2)) < 0 Then
    
27.                 qty = UBound(tier2s())
    
28.                 ReDim Preserve tier2s(1 To qty + 1)
    
29.                 tier2s(qty + 1) = tier2
    
30.                 areaList(tier1) = tier2s()
    
31.             End If
    
32.         End If
    
33.         Erase tier2s()
    
34.     Next
    
35.     Set selectList = areaList
    
36. End Function

复制代码

学良

若能将车牌号再加上就更适用了。如：
河北 [ 冀 ]
A 石家庄市  B 唐山市  C 秦皇岛市  D 邯郸市  E 邢台市  F 保定市
G 张家口市  H 承德市  J 沧州市  R 廊坊市  T 衡水市

morpheus126

请问数据来源和获取日期可以告知一下吗，谢谢~

NoooEnd

morpheus126 发表于 2023-3-19 21:00
请问数据来源和获取日期可以告知一下吗，谢谢~

有大佬开源的数据，最近更新的是2月份的数据

AreaCity 省市区县乡镇行政区划数据 + 坐标边界范围矢量数据

NoooEnd

学良 发表于 2023-3-19 20:48
若能将车牌号再加上就更适用了。如：
河北 [ 冀 ]
A 石家庄市  B 唐山市  C 秦皇岛市  D 邯郸市  E 邢台 ...

嗯，如果有数据源的话只需要加一列就可以了，代码只需要稍微追加一下就可以了

学良

回五楼：这是两天前下载的，你看一下吧！
全国牌照号.zip (16 KB, 下载次数: 45)

2023-3-20 08:17 上传

点击文件名下载附件

adad321

NoooEnd 发表于 2023-3-19 22:25
有大佬开源的数据，最近更新的是2月份的数据

AreaCity 省市区县乡镇行政区划数据 + 坐标边界范围矢量 ...

3207条数据，我还在用2989条的，还不敢随意更新，感觉最新的数据未必好，刚看了一下老客户的地址有些地址一直在用某开发区，这个3207的数据中却已经去除掉了。

但是呢...这个最新的数据我先拿走啦！对于对我有帮忙的人，我从来都是相当的感谢。

学良

NoooEnd 发表于 2023-3-19 22:35
嗯，如果有数据源的话只需要加一列就可以了，代码只需要稍微追加一下就可以了

数据源在六楼，请加一列吧。谢谢！

wangzqxa

谢谢楼主分享