excel VBA删除工作表后保存不了

yuanmeng7848

各位大师，正面这段程序是为了更新工作表数据，方法是在指定的工作簿中查找相应工作表，找到后将现有工作表删除，并将找到的新工作表数据拷贝到（插入）该位置，程序顺利扫后（查看数据确定所有工作表数据已更新）但却保存不了，点保存（或执行保存指令ThisWorkbook.Save）工作簿就会出现导演（自动重启），请各大师指点。
Sub copyfile()
Dim ShN As Integer
Application.ScreenUpdating = False
Dim wb As Workbook
Application.DisplayAlerts = False

f = Dir("E:\课程信息\排课草表.xls*") '将工作簿名赋值给f
If f = "" Then '如果对象文件不存在则退出程序
   MsgBox "“E:\课程信息\排课草表.xls*”文件不存在或文件路径不正确！"
   Exit Sub
Else
    ShN = 0
    Set wb = Workbooks.Open("E:\课程信息\" & f)
    i = 0
    Do While i < wb.Sheets.Count
       j = 0
       i = i + 1
       Do While j < ThisWorkbook.Sheets.Count
          j = j + 1
          If wb.Sheets(i).Name = ThisWorkbook.Sheets(j).Name Then
             ThisWorkbook.Sheets(j).Delete
             wb.Sheets(i).Copy ThisWorkbook.Sheets(j)
             ShN = ShN + 1
          End If
       Loop
    Loop
    'MsgBox wb.Sheets.Count & "与" & ShN
    If wb.Sheets.Count > ShN Then
       MsgBox "“E:\课程信息\课程总表.xls*”工作薄中的工作表名与本工作薄中工作表名不一至，" & vbCrLf & vbCrLf & "请将E:\课程信息\课程总表.xls*”工作薄中的工作表名改正后重新点击按钮！"
       wb.Close False
       Exit Sub
    End If
    wb.Close False
End If
f = Dir

Sheets(1).Activate '始终将工作表1作为活动工作表
End Sub

网海遨游

是不是要得到这样的呢？

Sub test()
     Application.DisplayAlerts = False: Application.ScreenUpdating = False '禁弹警告、禁止刷新
     mp = ThisWorkbook.Path & "\" '路径
     mf = Dir(mp & "*.xls*") '显示工作薄全名
               Do 'do循环（mf不等于空，就循环）
                    If ThisWorkbook.Name <> mf Then
                         Set wk = Workbooks.Open(mp & mf) '打开工作薄
                              For Each sh2 In wk.Sheets '遍历打开工作薄的工作表
                                   For Each sh1 In ThisWorkbook.Sheets '遍历有代码工作薄的工作表
                                        If sh1.Name <> "使用说明" Then
                                             If sh2.Name = sh1.Name Then '有相同名称的工作表
                                                  sh1.Activate '激活
                                                  sh1.Delete '删除工作表
                                                  sh2.Copy ThisWorkbook.Sheets(Sheets.Count) '复制工作表到此
                                                  Exit For
                                                  End If
                                             End If
                                   Next sh1
                              Next sh2
                         wk.Close False
                    End If
                    mf = Dir '显示下一个工作薄全名
               Loop While mf <> ""
               ThisWorkbook.Save '保存
     MsgBox "OK，完成！！！", 48, "温馨提示……"
     Application.DisplayAlerts = True: Application.ScreenUpdating = True '允许警告与刷新
End Sub

yuanmeng7848

谢谢提显，原来是没有激活工作表，问题解决了！