Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 34226|回复: 41

[分享] VBA中实现excel批量替换的代码

  [复制链接]
发表于 2011-3-10 15:23 | 显示全部楼层 |阅读模式
本帖最后由 兰色幻想 于 2011-3-10 22:13 编辑

       excel在替换时一次只能替换一个,如果成批替换设置公式也挺麻烦的,这里兰色就编写了一个批量替换程序,运行后就可以实现批量替换了。
Sub 批量替换()
On Error Resume Next
Dim 被替换区域 As Range
Dim 替换列表区域 As Range
Dim arr, arr1
Set 被替换区域 = Application.InputBox("请选取被替换的区域", "替换提示", , , , , , 8)
100:
Set 替换列表区域 = Application.InputBox("请选取替换规则的两列区域", "替换提示", , , , , , 8)
If UBound(替换列表区域.Value, 2) < 2 Then GoTo 100
arr = 被替换区域.Value
arr1 = 替换列表区域
For x = 1 To UBound(arr)
   For y = 1 To UBound(arr1)
     If arr(x, 1) Like "*" & arr1(y, 1) & "*" Then
       arr(x, 1) = Application.WorksheetFunction.Substitute(arr(x, 1), arr1(y, 1), arr1(y, 2))
       Exit For
     End If
    Next y
  Next x
  被替换区域 = arr
End Sub
使用方法:
     1 、Alt+f11打开VBE编辑器,插入---模块,把上面的代码粘贴到右边的窗口里,然后把光标放在程序语句中间,按F5运行(当然还可以用按钮执行或放在命令栏上执行)。
     2、在第一个提示框出现时,选取被替换的区域,这是一个单列的区域。
     3、在第二个提示框出现时,选出替换的2列区域,第一列是被替换的字符,第二列是对应替换后的字符。
     4、选取后替换就自动完成了,详见下面动画演示。

批量替换.gif

如果要实现区域且可以选取匹配是否的替换,可以用下面的代码:
Sub 批量替换()
On Error Resume Next
Dim 被替换区域 As Range
Dim 替换列表区域 As Range
Dim arr, arr1
Set 被替换区域 = Application.InputBox("请选取被替换的区域", "替换提示", , , , , , 8)
100:
Set 替换列表区域 = Application.InputBox("请选取替换规则的两列区域", "替换提示", , , , , , 8)
k = MsgBox("你是否要进行匹配替换,匹配点是,否则点“否”", 4 + 64)
If UBound(替换列表区域.Value, 2) < 2 Then GoTo 100
arr = 被替换区域.Value
arr1 = 替换列表区域
For q = 1 To 被替换区域.Areas.Count
arr = 被替换区域.Areas(q)
For X = 1 To UBound(arr)
   For y = 1 To UBound(arr1)
     If arr(X, 1) Like IIf(k = 6, arr1(y, 1), "*" & arr1(y, 1) & "*") Then
       arr(X, 1) = Application.WorksheetFunction.Substitute(arr(X, 1), arr1(y, 1), arr1(y, 2))
       Exit For
     End If
    Next y
  Next X
  被替换区域.Areas(q) = arr
Next q
End Sub

评分

参与人数 2 +2 收起 理由
Colinxu1628 + 1 赞一个
ibolee + 1 很给力!

查看全部评分

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2011-3-10 16:14 | 显示全部楼层
觉得自己认识VBA大迟了,谢谢兰版,我收藏了
回复

使用道具 举报

发表于 2011-3-10 16:14 | 显示全部楼层
回复

使用道具 举报

发表于 2011-3-10 16:48 | 显示全部楼层
用的过程中发现以下问题
1、执行结果后只替换选择的代替换区域第一列,如果要替换的数据不是第一列数据的话就不替换
2、能否达到匹配替换效果
回复

使用道具 举报

 楼主| 发表于 2011-3-10 16:50 | 显示全部楼层
代码和列没有关系啊,本来就是匹配规换,你说的匹配是怎么样的
回复

使用道具 举报

发表于 2011-3-10 17:04 | 显示全部楼层
本帖最后由 金刚 于 2011-3-10 18:24 编辑
兰色幻想 发表于 2011-3-10 16:50
代码和列没有关系啊,本来就是匹配规换,你说的匹配是怎么样的


例如旧代码中存在
YC-101(不替换)
C-101(替换成S3201)
如果YC-101不需要替换,只有C-101要进行替换,在执行的时候YC-101替换成YS3201了


回复

使用道具 举报

 楼主| 发表于 2011-3-10 17:18 | 显示全部楼层
金刚 发表于 2011-3-10 17:04
例如旧代码中存在
YC-101(不替换)
C-101(替换成S3201)

这样改一下,加一个选择:
Sub 批量替换()
On Error Resume Next
Dim 被替换区域 As Range
Dim 替换列表区域 As Range
Dim arr, arr1
Set 被替换区域 = Application.InputBox("请选取被替换的区域", "替换提示", , , , , , 8)
100:
Set 替换列表区域 = Application.InputBox("请选取替换规则的两列区域", "替换提示", , , , , , 8)
k = MsgBox("你是否要进行匹配替换,匹配点是,否则点“否”", 4 + 64)
If UBound(替换列表区域.Value, 2) < 2 Then GoTo 100
arr = 被替换区域.Value
arr1 = 替换列表区域
For x = 1 To UBound(arr)
   For y = 1 To UBound(arr1)
     If arr(x, 1) Like IIf(k = 6, arr1(y, 1), "*" & arr1(y, 1) & "*") Then
       arr(x, 1) = Application.WorksheetFunction.Substitute(arr(x, 1), arr1(y, 1), arr1(y, 2))
       Exit For
     End If
    Next y
  Next x
  被替换区域 = arr
End Sub
回复

使用道具 举报

发表于 2011-3-10 18:12 | 显示全部楼层
谢谢兰版  
回复

使用道具 举报

发表于 2011-3-10 18:28 | 显示全部楼层
金刚 发表于 2011-3-10 16:48
用的过程中发现以下问题
1、执行结果后只替换选择的代替换区域第一列,如果要替换的数据不是第一列数据的话 ...

要被替换的区域如果是多列好像不能全部替换,只有第一列能够替换,兰版能否帮忙测试一下多列数据的同时替换
回复

使用道具 举报

 楼主| 发表于 2011-3-10 18:31 | 显示全部楼层
Sub 批量替换()
On Error Resume Next
Dim 被替换区域 As Range
Dim 替换列表区域 As Range
Dim arr, arr1
Set 被替换区域 = Application.InputBox("请选取被替换的区域", "替换提示", , , , , , 8)
100:
Set 替换列表区域 = Application.InputBox("请选取替换规则的两列区域", "替换提示", , , , , , 8)
k = MsgBox("你是否要进行匹配替换,匹配点是,否则点“否”", 4 + 64)
If UBound(替换列表区域.Value, 2) < 2 Then GoTo 100
arr = 被替换区域.Value
arr1 = 替换列表区域
For x = 1 To UBound(arr)
for j=1 to ubound(arr,2)
   For y = 1 To UBound(arr1)
     If arr(x, j) Like IIf(k = 6, arr1(y, 1), "*" & arr1(y, 1) & "*") Then
       arr(x, j) = Application.WorksheetFunction.Substitute(arr(j, 1), arr1(y, 1), arr1(y, 2))
       Exit For
     End If
    Next y
  next j
  Next x
  被替换区域 = arr
End Sub
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 19:34 , Processed in 0.550319 second(s), 8 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表