[已解决]excel高级替换，部分替换匹配的内容，内含excel文件

grf1973

上附件，多点数据。

ATCkongguan

grf1973 发表于 2017-2-6 09:23
上附件，多点数据。

谢谢您的帮助，由于涉及隐私，我截取了一部分原文件，数据量应该够了。谢谢您

grf1973

1. Sub 替换()
   
2.     Dim arr
   
3.     Set d = CreateObject("scripting.dictionary")      '正向
   
4.     Set dr = CreateObject("scripting.dictionary")    '反向
   
5.     arr = Range("d2:e" & [e65536].End(3).Row)
   
6.     For i = 1 To UBound(arr)
   
7.         xrr = Split(Trim(arr(i, 2)), " ")
   
8.         y = ""
   
9.         For k = UBound(xrr) To 0 Step -1
   
10.             y = y & " " & xrr(k)
    
11.         Next
    
12.         x = Trim(arr(i, 1))
    
13.         d(x) = Trim(arr(i, 2))
    
14.         dr(x) = Mid(y, 2)
    
15.     Next
    
16.    
    
17.     arr = Range("a1:c" & [a65536].End(3).Row)
    
18.     With CreateObject("vbscript.regexp")
    
19.         .Global = True
    
20.         For i = 2 To UBound(arr)
    
21.             x = arr(i, 2)
    
22.             a = Split(x, " ")
    
23.             For j = 0 To UBound(a)
    
24.                 s = Trim(a(j))
    
25.                 If d.exists(s) Then
    
26.                      ks = a(j - 1): js = a(j + 1)
    
27.                     .Pattern = ks & "( .+ )" & js
    
28.                     If .test(d(s)) Then
    
29.                         Set mh = .Execute(d(s))
    
30.                         fx = "正向"
    
31.                     Else
    
32.                         Set mh = .Execute(dr(s))   '如果正向没有，反向查找一遍
    
33.                         fx = "反向"
    
34.                     End If
    
35.                     If mh.Count = 0 Then
    
36.                         arr(i, 3) = "未替换"      'x
    
37.                     Else
    
38.                         xstr = Trim(mh(0).submatches(0))
    
39.                         arr(i, 3) = s & fx & "：" & Replace(x, s, xstr)
    
40.                         Exit For
    
41.                     End If
    
42.                 End If
    
43.             Next
    
44.         Next
    
45.     End With
    
46.     Range("a1:c" & [a65536].End(3).Row) = arr
    
47. End Sub

复制代码

ATCkongguan

grf1973 发表于 2017-2-6 13:54

谢谢您的帮助[em17]！

ATCkongguan

grf1973 发表于 2017-2-6 13:54

大神您好，批量替换的程序非常好用，但是我手里的数据过于杂乱且没有规律，替换起来难度异常大。  见图（循环批量替换后还是有道路没有替换成点串，而且循环替换过程容易漏掉一些未替换道路）。  因此我想到的解决方法是在正反向替换基础上，请您做一步改进，我再手工完成一部分。实在抱歉，还要再麻烦您一下。

grf1973

没有道路替换是因为不符合替换条件。有些道路虽然有点串，但在源数据中点串+道路代码+点串匹配不到，或者无需匹配。

grf1973

另外， 对源数据，我设置成替换一次成功直接退出循环。要针对源数据某条记录中所有的道路都判断替换吗？

ATCkongguan

grf1973 发表于 2017-2-6 16:40
另外， 对源数据，我设置成替换一次成功直接退出循环。要针对源数据某条记录中所有的道路都判断替换吗？

最终目的是源数据中道路都替换成点串，而源数据的格式是：点+道路+点+道路...交替开的。  我也是在没辙了

ATCkongguan

grf1973 发表于 2017-2-6 16:40
另外， 对源数据，我设置成替换一次成功直接退出循环。要针对源数据某条记录中所有的道路都判断替换吗？

要对某条数据中所有道路都进行判断替换，才能最终达到目的，实在是太复杂了，辛苦您了。  没有其他好办法的话您看我说的人工逐条替换可行吗？

grf1973

按你要求重新做了一个。输出数据前半部分是为了清楚一点。当然前半部分可以不显示的。