求大神帮我做一个宏，以达到省市区的自动匹配

huang1314wei

如附件所示，在省市区规则工作簿里面有两个表，具体要求如下：1、A表里面是省市区规则，B表里面是需要匹配的数据
2、在B表里面，有若干条数据，省和区是已知的，希望能运行一下宏就可以达到省市区的自动匹配
3、在B表里面A列与C列单元格数据有的时候是不完整的，比如“山西省”有的时候只有“山西”两个字，“河北省”只有“河北”两个字，C列里面单元格数据有的时候“XX区”或“XX县”只有“XX”两个字，希望匹配的时候，只需要较验省的前两个字，区的前两个字，点击控件按钮，运行一下宏就可以自动在B表里面的A列、B列、C列自动生成XX省XX市XX区的完整省市区，如匹配不成功，以红底纹提示就行了希望有大神能相助。
省市区规则.rar (70 KB, 下载次数: 248)

2015-4-4 08:19 上传

点击文件名下载附件
附件

huang1314wei

二年级班长 发表于 2015-7-26 10:23
学习中，哈哈

哈哈，啥时候把我以前发的求助贴翻出来了？

4个月前，我对VBA一窍不通，那个时候想要达到什么目的也是到处求人，求人不如求自己，只有自己会了，就不用求人了。记得那个时候，蓝版主帮我写的代码和yjh_27的代码我怎么也看不懂，看天书一样，要改也不知道哪里改起，从这个时候开始，我就下定了决心要学习VBA，听了几期免费公开课，连续买了两本VBA书，《别怕，Excel其实很简单》、《Excel VBA实战技巧精粹》利用空余时间钻研，对VBA的学习进步很快，目前大部分问题我还是能通过代码解决的，再回过头来看一下自己以前的求助，其实只有懂了才会觉得没什么难的，不久前还被贴上了一个优秀会员标签，其实一直想把自己学习VBA的心得写下来分享给大家，只是没有那么多时间组织文字，有空再理理这个事吧

jpj123

如匹配不成功,
是什么意思？是所在省没有这个市县吗？

jpj123

1. Sub 按钮1_Click()
   
2. Dim arr, i%, j%, n%, brr, m%
   
3. Sheets("B").Range("E:G").Clear
   
4. arr = Sheets("A").UsedRange
   
5. brr = Sheets("B").UsedRange
   
6. For m = 1 To UBound(brr)
   
7. For j = 1 To UBound(arr, 2)
   
8. For i = 1 To UBound(arr)
   
9. If InStr(arr(i, j), brr(m, j)) > 0 Then
   
10. brr(m, j) = arr(i, j)
    
11. End If
    
12. Next
    
13. Next
    
14. Next
    
15. Sheets("B").Range("E1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
16. End Sub
    

复制代码

jpj123

为了便于对比，数据没放在原来的位置。

huang1314wei

jpj123 发表于 2015-4-4 08:57
如匹配不成功,
是什么意思？是所在省没有这个市县吗？

是的，就是区县不正确

huang1314wei

jpj123 发表于 2015-4-4 09:12
为了便于对比，数据没放在原来的位置。

你这个做的不对的，B表里面的F列生成的全部都是市辖区是不行的，比如河北省  辛集市在A表里面是河北省石家庄市辛集市，但是你生成的是河北省市辖区辛集市是不对的，麻烦大侠再改改

jpj123

huang1314wei 发表于 2015-4-4 13:00
你这个做的不对的，B表里面的F列生成的全部都是市辖区是不行的，比如河北省  辛集市在A表里面是河北省石家 ...

1. Sub 按钮1_Click()
   
2. Dim arr, i%, j%, n%, brr, m%
   
3. Sheets("B").Range("E:G").Clear
   
4. arr = Sheets("A").UsedRange
   
5. brr = Sheets("B").UsedRange
   
6. For m = 1 To UBound(brr)
   
7. For i = 1 To UBound(arr)
   
8. If InStr(arr(i, 1), brr(m, 1)) > 0 And InStr(arr(i, 3), brr(m, 3)) > 0 Then
   
9. brr(m, 1) = arr(i, 1): brr(m, 2) = arr(i, 2): brr(m, 3) = arr(i, 3)
   
10. End If
    
11. Next
    
12. Next
    
13. Sheets("B").Range("E1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
14. End Sub
    

复制代码

jpj123

修改了代码，详见附件     

jpj123

jpj123 发表于 2015-4-4 13:46
修改了代码，详见附件

如果匹配不成功的话第二列不会有数据。

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, x$, y$, Brr, j&, jj&, aa
   
3. Dim d, k, t, kk, tt, s$, ss$, q$, qq$
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Sheet2.Activate
   
6. Brr = Sheet2.UsedRange
   
7. Arr = Sheet1.[a1].CurrentRegion
   
8. For i = 1 To UBound(Arr)
   
9.     x = Left(Arr(i, 1), 2): y = Left(Arr(i, 3), 2)
   
10.     If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")
    
11.     d(x)(y) = d(x)(y) & i & ","
    
12. Next
    
13. k = d.keys
    
14. For i = 1 To UBound(Brr)
    
15.     s = Left(Brr(i, 1), 2)
    
16.     If d.exists(s) Then
    
17.         q = Left(Brr(i, 3), 2)
    
18.         kk = d(s).keys: tt = d(s).items
    
19.         For j = 0 To UBound(kk)
    
20.             If InStr(kk(j), q) Then
    
21.                 t = tt(j): ss = "": qq = ""
    
22.                 t = Left(t, Len(t) - 1)
    
23.                 If InStr(t, ",") Then
    
24.                     aa = Split(t, ",")
    
25.                     Cells(i, 5) = Arr(aa(0), 1)
    
26.                     For jj = 0 To UBound(aa)
    
27.                         ss = ss & Arr(aa(jj), 2) & " ": qq = qq & Arr(aa(jj), 3) & " "
    
28.                     Next
    
29.                     Cells(i, 6) = ss: Cells(i, 7) = qq
    
30.                 Else
    
31.                     Cells(i, 5) = Arr(t, 1): Cells(i, 6) = Arr(t, 2): Cells(i, 7) = Arr(t, 3)
    
32.                 End If
    
33.                 GoTo 100
    
34.             End If
    
35.         Next
    
36.         Cells(i, 3).Interior.ColorIndex = 3
    
37.     End If
    
38. 100:
    
39. Next
    
40. End Sub
    

复制代码