求助，运行卡死

代码：
Sub Find()
Application.ScreenUpdating = False
Dim MyDir As String
MyDir = ThisWorkbook.Path &"\"
ChDrive Left(MyDir, 1) 'find all the excelfiles
ChDir MyDir
Match = Dir$("")
Do
If Not LCase(Match) =LCase(ThisWorkbook.Name) Then
Workbooks.Open Match, 0 'open
Worksheets("sheet1").range("B5") = 20
ActiveWindow.Close 1
Match = Dir$
End If
Loop Until Len(Match) = 0
Application.ScreenUpdating = True
End Sub
自己啥也不会，自己在网上拼的代码，运行卡死，必须任务管理干掉。希望有人帮我修改下，需求是，批量修改工作簿制定Sheet指定单元格数据。有大量的工作簿是相同的模板。

把需求整理出来

不感兴趣

开通SVIP免广告

可能需要在do后一行加入DoEvents

Sub Find()
Dim DirStr$, ExcelFilePath$, n&
Dim xlApp As Object, xlBook As Object
ExcelFilePath = "D:\新建文件夹\" '自己修改你需要处理的目录
Print "正在修改" & ExcelFilePath & "目录下的工作簿..."
DirStr = Dir(ExcelFilePath & "*.xlsx")
Set xlApp = CreateObject("Excel.Application")
Do While DirStr <> ""
n = n + 1
Print "修改第" & n & "个工作簿..."
Set xlBook = xlApp.workbooks.open(ExcelFilePath & DirStr)
xlBook.sheets("Sheet1").range("B5").Value = 20 '自己修改需要处理的sheet和单元格
xlBook.Close SAVECHANGES:=True
DirStr = Dir
Loop
xlApp.QUIT
Set xlApp = Nothing
Print "修改完成！"
End Sub

扫二维码下载贴吧客户端

下载贴吧APP
看高清直播、视频！

4回复贴，共1页

<<返回vb吧

分享到:

日	一	二	三	四	五	六