对指定文件夹里所有EXCEL：除包含关键字“供应商”的工作表外，其余工作表jun'shan...

life冰晓雨

Public Sub 批删工作表()
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Fileame As String, lnt As String, fn As String, ab As String, sht As Worksheet, wb As Workbook, xl As String
    ab = "供应商"
    lnt = "D:\Personal\桌面\产前原始文件\"
    If lnt <> "" Then
    xl = lnt & "*.xl*"
    Fileame = Dir(xl)
    fn = lnt & Fileame
    Do While Fileame <> ""
        Set wb = GetObject(fn)
        If wb.Worksheets.Count > 1 Then
            For Each sht In wb.Worksheets
                    If UCase(sht.Name) Like "*" & UCase(ab) & "*" Then
                        sht.Name = wb.Name
                    Else
                        sht.Delete
                        End If
        If wb.Worksheets.Count = 1 Then
            Exit For
        End If
            Next
                Fileame = Dir
        End If
    Loop
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

代码如上，需要对指定文件夹里所有EXCEL文件批量操作：除包含关键字“供应商”的工作表外，其余工作表都删除。
但是代码运行后无响应，麻烦各位大神帮忙看看哪里出问题了

ykcbf1100

上传附件吧。

shiruiqiang

没看见有wk.save 和wk.close的代码

陆离Lowry

盲猜，把Fileame = Dir 这句往下移一行，放在end if下面看，没看到附件，不知道是不是第一个工作簿就只有一张表，就死循环了

半百

试试这样可行？