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

ATCkongguan · 发表于 2017-1-10 20:36

excel高级替换，部分替换匹配的内容，内含excel文件，文件中包含对问题的描述！！！

最佳答案

today0427

2017-1-11 14:03

本帖最后由 today0427 于 2017-1-11 15:07 编辑

我估计，第一，要替换的数据源还有很多；第二，道路名称也不可能只有H13一个，也就是说要替换的关键词可能会有变化，因此做了个通用的自定义函数。
效果如图：左边黄色区域分别是数据源，要替换的关键字和替换结果，右边蓝色区域是道路代码及字符串（注意，找到就替换，找不到就照抄）

Dim d As Object, n%
Function td(rng As Range, s$) As String
If n = 0 Then Call csh
Dim str$, ar, a, j%, ks$, js$, mh
a = Split(rng.Text, " ")
For j = 0 To UBound(a)
If a(j) = s Then ks = a(j - 1): js = a(j + 1): Exit For
Next
With CreateObject("vbscript.regexp")
.Pattern = ks & "(.*)?" & js
Set mh = .Execute(d(s))
If mh.Count = 0 Then
td = rng
Else
str = Trim(mh(0).submatches(0))
td = Replace(rng.Text, s, str)
End If
End With
End Function
Sub csh()
Dim arr
Set d = CreateObject("scripting.dictionary")
arr = Range("e2:f" & [e65536].End(3).Row)
For i = 1 To UBound(arr)
d(arr(i, 1)) = arr(i, 2)
Next
n = 1
End Sub

复制代码

跳转到最佳答案楼层

sandorn · 发表于 2017-1-10 22:12

看一看！！！！！

砂海 · 发表于 2017-1-11 11:50

不用Vba 就是坑

下面是 ( 纯函数 + 辅助单元格 ) , 别问为什么

高级替换-(坑)--求助.rar (10.31 KB, 下载次数: 15)

today0427 · 发表于 2017-1-11 14:03

这个最佳答案由 today0427 给出，感谢 today0427 的回答。

单击隐藏图章

本帖最后由 today0427 于 2017-1-11 15:07 编辑

我估计，第一，要替换的数据源还有很多；第二，道路名称也不可能只有H13一个，也就是说要替换的关键词可能会有变化，因此做了个通用的自定义函数。
效果如图：左边黄色区域分别是数据源，要替换的关键字和替换结果，右边蓝色区域是道路代码及字符串（注意，找到就替换，找不到就照抄）

Dim d As Object, n%
Function td(rng As Range, s$) As String
If n = 0 Then Call csh
Dim str$, ar, a, j%, ks$, js$, mh
a = Split(rng.Text, " ")
For j = 0 To UBound(a)
If a(j) = s Then ks = a(j - 1): js = a(j + 1): Exit For
Next
With CreateObject("vbscript.regexp")
.Pattern = ks & "(.*)?" & js
Set mh = .Execute(d(s))
If mh.Count = 0 Then
td = rng
Else
str = Trim(mh(0).submatches(0))
td = Replace(rng.Text, s, str)
End If
End With
End Function
Sub csh()
Dim arr
Set d = CreateObject("scripting.dictionary")
arr = Range("e2:f" & [e65536].End(3).Row)
For i = 1 To UBound(arr)
d(arr(i, 1)) = arr(i, 2)
Next
n = 1
End Sub

复制代码

ATCkongguan · 发表于 2017-1-13 07:48

砂海发表于 2017-1-11 11:50
不用Vba 就是坑

下面是 ( 纯函数 + 辅助单元格 ) , 别问为什么

谢谢你的帮助

ATCkongguan · 发表于 2017-1-13 07:49

today0427 发表于 2017-1-11 14:03
我估计，第一，要替换的数据源还有很多；第二，道路名称也不可能只有H13一个，也就是说要替换的关键词可能 ...

请受我一拜[em17]

kmcla · 发表于 2017-1-13 07:58

神人，你都做到工机料替换了。考过一建后我也做一个

yonhe · 发表于 2017-1-13 10:39

下载学习一下!

grf1973 · 发表于 2017-1-13 15:27

4楼的基础上再加个反向查找就完美了。

Dim d, dr, n%
Function td(rng As Range, s$) As String
If n = 0 Then Call csh
Dim str$, ar, a, j%, ks$, js$, mh
a = Split(rng.Text, " ")
For j = 0 To UBound(a)
If a(j) = s Then ks = a(j - 1): js = a(j + 1): Exit For
Next
With CreateObject("vbscript.regexp")
.Pattern = ks & "(.*)?" & js
Set mh = .Execute(d(s))
If mh.Count = 0 Then Set mh = .Execute(dr(s)) '如果正向没有，反向查找一遍
If mh.Count = 0 Then
td = rng
Else
str = Trim(mh(0).submatches(0))
td = Replace(rng.Text, s, str)
End If
End With
End Function
Sub csh()
Dim arr
Set d = CreateObject("scripting.dictionary")
Set dr = CreateObject("scripting.dictionary") '反向
arr = Range("d2:e" & [e65536].End(3).Row)
For i = 1 To UBound(arr)
xrr = Split(arr(i, 2), " ")
For k = UBound(xrr) To 0 Step -1
y = y & " " & xrr(k)
Next
d(arr(i, 1)) = arr(i, 2)
dr(arr(i, 1)) = Mid(y, 2)
Next
n = 1
End Sub

复制代码

ATCkongguan · 发表于 2017-2-5 23:07

grf1973 发表于 2017-1-13 15:27
4楼的基础上再加个反向查找就完美了。

两位大神新年快乐，谢谢你们的指导！最后的问题就是多参数时怎么替换，数据量非常大，单个替换臣妾办不到啊[em06]

问题最新描述见下图，请指教！

		自动登录	找回密码
密码			注册

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

相关帖子

点评