大神请进，根据省市区县对应表自动提取快递大头笔

yjh_27

long237043787 发表于 2016-5-26 14:13
现在比较难以避免的就是白云两个字，对应的有云南、广州、新疆什么的，那如果转换成代码，不同代码对应的是 ...

实际情况还要复杂

你在对照表中 搜“安县”，看有多少结果

HB郑

很久一位大师写了一个省县市匹配代码，现给供你参考。

long237043787

其实我想了一下，即使安县有几十个，但是还要加上前面的市和省，这样再转成对应的省市代码去，代码编码规则可以自己指定，那这样子来说，每次去提取对应大头笔的时候，只在数据库里找到唯一能对应的值，找不到就返回为空值（空值的情况就完善对应表），保证查找的时候是有唯一对应值，这样程序才简洁而且不出错。

long237043787

比如说安县，虽然有几十个，但是安县是不同区的，它们都能按规则指定唯一一个不重复的编码序号，查找取大头笔的时候就找到对应编码序号进行取值，就可以是唯一的。

jsgj2023

楼主，这个问题解决了吗？

jsgj2023

1. Sub 快递大头笔取值对照表()
   
2.         Dim R&, Arr, d As Object, x&, Brr, Crr
   
3.         Dim R1&, i&, j&, S, S1, Reg, a&, b&, mat, ma, k&
   
4.         Application.ScreenUpdating = False
   
5.         Set Reg = CreateObject("Vbscript.RegExp")
   
6.         Sheet2.Activate
   
7.         R = Cells(Rows.Count, 5).End(xlUp).Row
   
8.         Arr = Range("a1:f" & R)
   
9.         Set d = CreateObject("scripting.dictionary")
   
10.         For x = 2 To UBound(Arr)
    
11.                 If Arr(x, 5) <> "香港" And Arr(x, 5) <> "澳门" And Left(Arr(x, 5), 2) <> "台湾" Then
    
12.                         If Not d.exists(Arr(x, 5)) Then
    
13.                                 d(Arr(x, 5)) = Arr(x, 6)
    
14.                         End If
    
15.                  End If
    
16.         Next x
    
17.         S = d.keys: S1 = d.items
    
18.         Sheet1.Activate
    
19.                 R1 = Cells(Rows.Count, 1).End(xlUp).Row
    
20.                 Brr = Range("a1:c" & R1)
    
21.                 ReDim Crr(1 To UBound(Brr), 1 To UBound(Brr, 2) - 1)
    
22.         With Reg
    
23.                 .Global = True
    
24.                 .Pattern = ".+(省|市|[^小]区|县|街道办事处|街道办|街道|[^小]区|镇|乡)"
    
25.         End With
    
26.         For a = 2 To UBound(Brr)
    
27.                 Set mat = Reg.Execute(Brr(a, 1))
    
28.                 For Each ma In mat
    
29.                         k = k + 1
    
30.                        Crr(k + 1, 1) = ma
    
31.                 Next ma
    
32.         Next a
    
33.          For j = 2 To UBound(Crr)
    
34.                 For i = 0 To d.Count - 1
    
35.                         If InStr(Crr(j, 1), Mid(S(i), 2, 99)) > 0 Then
    
36.                                 Crr(j, 1) = S(i)
    
37.                                 Crr(j, 2) = S1(i)
    
38.                         End If
    
39.                 Next i
    
40.         Next j
    
41.         [b1].Resize(UBound(Brr), UBound(Brr, 2) - 1) = Crr
    
42.         [a1].Resize(1, 3) = Array("地址", "大头笔", "包编号")
    
43.         Application.ScreenUpdating = True
    
44. End Sub

复制代码