[已解决]求大神优化一下代码。

柒分壊

Sub 批量替换()
Application.ScreenUpdating = False
Dim wb As Excel.Workbook
f = Dir(ThisWorkbook.Path & "\*.xl*") '生成查找EXCEL的目录,可以适应不同版本
Do While f <> "" '在目录中循环
If f <> ThisWorkbook.Name Then  '如果不是打开的工作簿
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f) '依次打开目录工作薄
  Sheets("Sheet1").Select
     ActiveWorkbook.Save
  Cells.Replace What:="地基承载力", Replacement:=" ", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    wb.Close True
    End If
    f = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

网上找的这段代码，可以运行，想让显示在表格中，最好能一次多替换几个。拜托各位大佬了，十分感谢

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2021-11-14 12:46

没有附件，猜的。

1. Sub 批量替换()
   
2. Dim arr, i&
   
3. arr = ActiveSheet.[a1].CurrentRegion
   
4. Application.ScreenUpdating = False
   
5. Dim wb As Excel.Workbook
   
6. f = Dir(ThisWorkbook.Path & "\*.xl*") '生成查找EXCEL的目录,可以适应不同版本
   
7. Do While f <> "" '在目录中循环
   
8.     If f <> ThisWorkbook.Name Then  '如果不是打开的工作簿
   
9.         Set wb = Workbooks.Open(ThisWorkbook.Path & "" & f) '依次打开目录工作薄
   
10.         Sheets("Sheet1").Select
    
11.         ActiveWorkbook.Save
    
12.         For i = 2 To UBound(arr)
    
13.             Cells.Replace What:=arr(i, 1), Replacement:=arr(i, 2), LookAt:=xlPart, _
    
14.                 SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    
15.                 ReplaceFormat:=False
    
16.         Next i
    
17.         wb.Close True
    
18.     End If
    
19.     f = Dir
    
20. Loop
    
21. Application.ScreenUpdating = True
    
22. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

没有附件，猜的。

1. Sub 批量替换()
   
2. Dim arr, i&
   
3. arr = ActiveSheet.[a1].CurrentRegion
   
4. Application.ScreenUpdating = False
   
5. Dim wb As Excel.Workbook
   
6. f = Dir(ThisWorkbook.Path & "\*.xl*") '生成查找EXCEL的目录,可以适应不同版本
   
7. Do While f <> "" '在目录中循环
   
8.     If f <> ThisWorkbook.Name Then  '如果不是打开的工作簿
   
9.         Set wb = Workbooks.Open(ThisWorkbook.Path & "" & f) '依次打开目录工作薄
   
10.         Sheets("Sheet1").Select
    
11.         ActiveWorkbook.Save
    
12.         For i = 2 To UBound(arr)
    
13.             Cells.Replace What:=arr(i, 1), Replacement:=arr(i, 2), LookAt:=xlPart, _
    
14.                 SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    
15.                 ReplaceFormat:=False
    
16.         Next i
    
17.         wb.Close True
    
18.     End If
    
19.     f = Dir
    
20. Loop
    
21. Application.ScreenUpdating = True
    
22. End Sub

复制代码

柒分壊

大灰狼1976 发表于 2021-11-14 12:46
没有附件，猜的。

抱歉，附件没传，现在补上，麻烦再帮忙看看吧，谢谢了。

大灰狼1976

柒分壊 发表于 2021-11-14 15:57
抱歉，附件没传，现在补上，麻烦再帮忙看看吧，谢谢了。

你先试下代码，我今天估计没时间看。

柒分壊

大灰狼1976 发表于 2021-11-14 17:36
你先试下代码，我今天估计没时间看。

代码试了的，运行出错，我完全看不懂哪里错了。。尴尬。等老师有空给看吧，我可以等

cutecpu

柒分壊 发表于 2021-11-14 17:56
代码试了的，运行出错，我完全看不懂哪里错了。。尴尬。等老师有空给看吧，我可以等

Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f)

柒分壊

cutecpu 发表于 2021-11-14 18:35
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f)

成了，谢谢cutecpu、大灰狼1976 两位老师。十分感谢

大灰狼1976

柒分壊 发表于 2021-11-14 17:56
代码试了的，运行出错，我完全看不懂哪里错了。。尴尬。等老师有空给看吧，我可以等

论坛经常会把代码里的反斜杠吃掉。