VBA 地址模糊匹配 两个表

zky87@163.com

如附件，在详细地址工作表A列有若干地址，在简称工作表中有若干简称，当简称工作表中无对应名称，添加后运行VBA可匹配。

收货人详细地址	简称
华立·天地豪园21栋	华立·天地豪园
万科悦峰1期7栋	万科悦峰
龙湖源著南区10栋	龙湖·源著
国际社区观邸1组团(北门)	国际社区
龙湖·春森彼岸1期10栋	龙湖·春森彼岸
盘溪路420号 龙湖·源著3期28栋	龙湖·源著
国际社区观邸3组团(东南门)南岸区腾龙大道国际社区观邸三组团12栋	国际社区
龙湖·春森彼岸(长兴路)12栋	龙湖·春森彼岸

yeminqiang

1. Sub cdsr()
   
2.     Dim arr, brr
   
3.     arr = Sheet2.[a1].CurrentRegion
   
4.     lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
   
5.     brr = Sheet1.Range("a1:b" & lastrow)
   
6.     brr(1, 2) = "简称"
   
7.     For i = 2 To UBound(brr)
   
8.         For j = 2 To UBound(arr)
   
9.             If InStr(brr(i, 1), arr(j, 1)) Then
   
10.                 brr(i, 2) = arr(j, 1)
    
11.             End If
    
12.         Next
    
13.     Next
    
14.     Sheet1.[a1:b50000] = ""
    
15.     Sheet1.[a1].Resize(UBound(brr), 2) = brr
    
16. End Sub

复制代码

zky87@163.com

yeminqiang 发表于 2016-6-29 17:08

谢谢！很好的解决了问题