在文件夹中循环excel工作簿并删除除一张工作表以外的所有工作表

尝试拼凑一些VBA来完成一个相当简单的任务。循环浏览包含.xlsx文件的文件夹，打开每个文件，删除所有工作簿中除名称一致的工作表以外的所有工作表，并以相同的名称保存工作簿

下面是代码，但不断抛出错误

Public Sub RemoveSheetsLoopThroughFiles()
    
    Dim targetWorkbook As Workbook
    Dim ws As Worksheet
    
    Dim filePath As String
    Dim folderPath As String
    Dim folderWildcard As String
    
    folderPath = "[folder]\"
    folderWildcard = "*.xlsx"
     
    ' Get the file path concat folder and wildcards
    filePath = Dir(folderPath & folderWildcard)
      
    Do While Len(filePath) > 0
        ' Open the workbook and set reference
        Set targetWorkbook = Workbooks.Open(Filename:=filePath)
        'Set targetWorkbook = Workbooks.Open(folderPath & folderWildcard)
        
        For Each ws In targetWorkbook ERROR HIGHLIGHT OCCURRING HERE
        Application.DisplayAlerts = False
        If ws.Name <> "[sheet name to keep]" Then
        ws.Delete
        End If
        
        Next ws
        'Application.DisplayAlerts = True

        'Debug.Print filePath
        
        filePath = Dir
        
        targetWorkbook.Close True
        
        'Set targetWorkbook = Nothing

        
    Loop
    
MsgBox ("all sheets removed")
    
End Sub

Public Sub-RemoveSheetsLoopThroughFiles（）
将targetWorkbook设置为工作簿
将ws设置为工作表
将文件路径设置为字符串
将folderPath设置为字符串
Dim folderWildcard作为字符串
folderPath=“[folder]\”
folderWildcard=“*.xlsx”
'获取concat文件夹的文件路径和通配符
filePath=Dir（folderPath和folderWildcard）
当Len（文件路径）>0时执行
'打开工作簿并设置引用
设置targetWorkbook=Workbooks.Open（文件名：=filePath）
'Set targetWorkbook=Workbooks.Open（folderPath&folderWildcard）
对于targetWorkbook中的每个ws，此处会突出显示错误
Application.DisplayAlerts=False
如果ws.Name“[要保留的图纸名称]”则
ws.Delete
如果结束
下一个ws
'Application.DisplayAlerts=True
'Debug.Print文件路径
filePath=Dir
targetWorkbook。关闭为真
'设置targetWorkbook=无
环
MsgBox（“删除所有图纸”）
端接头

对于此处发生的targetWorkbook中的每个ws错误突出显示，请将其更改为For Each ws In targetWorkbook.Worksheets。也无需在循环中使用Application.DisplayAlerts=True/False或Set-targetWorkbook=Nothing；）您可能还希望看到优化VBA代码并提高如何使用事件的性能–Siddharth Rout 21分钟前

顺便说一句，设置targetWorkbook=Workbooks.Open（文件名：=filePath）应设置targetWorkbook=Workbooks.Open（文件名：=folderPath&filePath）–Siddharth Rout 2分钟前编辑删除

根据我的评论，试试这个。我对它进行了测试，结果很好

Option Explicit

Sub Sample()
    Dim scrnUpdating As Boolean
    Dim dsplyAlerts As Boolean
    
    Dim wb As Workbook
    Dim ws As Worksheet
    
    On Error GoTo Whoa
    
    Dim fldr As String: fldr = "C:\Users\routs\Desktop\Test\"
    Dim FileExtn As String: FileExtn = "*.xlsx"
    Dim filePath  As String
    
    filePath = Dir(fldr & FileExtn)
    
    With Application
        '~~> Get user's current setting
        scrnUpdating = .ScreenUpdating
        dsplyAlerts = .DisplayAlerts
        
        '~~> Set it to necessary setting
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
   
    Do While Len(filePath) > 0
        Set wb = Workbooks.Open(Filename:=fldr & filePath)
        
        If wb.Worksheets.Count > 1 Then
            For Each ws In wb.Worksheets
                If ws.Name <> "[sheet name to keep]" Then ws.Delete
            Next ws
        Else
            MsgBox wb.Name & " ignored as it contains only 1 worksheet"
        End If
        
        wb.Close True
        DoEvents
        
        filePath = Dir
    Loop        
    MsgBox "All sheets removed"       
LetsContinue:
    With Application
        '~~> Reset original settings
        .ScreenUpdating = scrnUpdating
        .DisplayAlerts = dsplyAlerts
    End With
    
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub

选项显式
子样本（）
Dim SCRN更新为布尔值
作为布尔值的Dim dsplyAlerts
将wb设置为工作簿
将ws设置为工作表
关于错误转到哇
Dim fldr As String:fldr=“C:\Users\routs\Desktop\Test\”
Dim FileExtn作为字符串：FileExtn=“*.xlsx”
将文件路径设置为字符串
filePath=Dir（fldr&FileExtn）
应用
“~~>获取用户的当前设置
scrnUpdating=.ScreenUpdating
dsplyAlerts=.DisplayAlerts
“~~>将其设置为必要的设置
.ScreenUpdate=False
.DisplayAlerts=False
以
当Len（文件路径）>0时执行
设置wb=Workbooks.Open（文件名：=fldr&filePath）
如果wb.Worksheets.Count>1，则
对于wb.工作表中的每个ws
如果ws.Name“[sheet Name to keep]”，则ws.Delete
下一个ws
其他的
MsgBox wb.Name&“已忽略，因为它只包含1个工作表”
如果结束
wb.Close为真
多芬特
filePath=Dir
环
MsgBox“已删除所有图纸”
让我们继续：
应用
“~~>重置原始设置
.ScreenUpdating=scrnUpdating
.DisplayAlerts=dsplyAlerts
以
出口接头
哇
MsgBox错误说明
继续
端接头

Dir

feat<代码>阵列列表

• 下面将循环遍历文件夹中的所有

  .xlsx

  文件，打开每个文件，将每个工作表的名称写入

  数组列表

  ，然后从列表中删除指定的名称（不区分大小写），然后删除名称保留在列表中的工作表，最后保存工作簿（文件）
• 如果指定名称的工作表不存在或是工作簿中唯一的工作表，则不会执行任何操作，即关闭工作簿而不保存更改
• 调整常量部分中的值注意在这个解决方案中，

  FolderPath

  必须以反斜杠（

  \

  ）结束

代码

Option Explicit

Public Sub RemoveSheetsLoopThroughFiles()
    
    Dim ws As Worksheet
    
    Const FolderPath As String = "F:\Test\"
    Const FolderWildcard As String = "*.xlsx"
    Const wsName As String = "Sheet1"
    
    Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
    
    Dim FileName As String
    FileName = Dir(FolderPath & FolderWildcard)
    
    Application.ScreenUpdating = False
    
    Do While Len(FileName) > 0
        With Workbooks.Open(FileName:=FolderPath & FileName)
            For Each ws In .Worksheets
                arl.Add ws.Name
            Next ws
            If arl.Contains(wsName) And arl.Count > 1 Then
                arl.Remove wsName
                Application.DisplayAlerts = False
                .Worksheets(arl.ToArray).Delete
                .Close SaveChanges:=True
                Application.DisplayAlerts = True
            Else
                .Close SaveChanges:=False
            End If
        End With
        arl.Clear
        FileName = Dir
    Loop
    
    Application.ScreenUpdating = True
    
    MsgBox ("all sheets removed")
    
    'ThisWorkbook.FollowHyperlink FolderPath
    
End Sub

编辑：

字典解决方案

Public Sub RemoveSheetsLoopThroughFilesDictionary()
    
    Dim ws As Worksheet
    
    Const FolderPath As String = "F:\Test\"
    Const FolderWildcard As String = "*.xlsx"
    Const wsName As String = "Sheet1"
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim FileName As String
    FileName = Dir(FolderPath & FolderWildcard)
    
    Application.ScreenUpdating = False
    
    Do While Len(FileName) > 0
        With Workbooks.Open(FileName:=FolderPath & FileName)
            For Each ws In .Worksheets
                dict.Add ws.Name, Empty
            Next ws
            If dict.Exists(wsName) And dict.Count > 1 Then
                dict.Remove wsName
                Application.DisplayAlerts = False
                .Worksheets(dict.Keys).Delete
                .Close SaveChanges:=True
                Application.DisplayAlerts = True
            Else
                .Close SaveChanges:=False
            End If
        End With
        dict.RemoveAll
        FileName = Dir
    Loop
    
    Application.ScreenUpdating = True
    
    MsgBox ("all sheets removed")
    
    'ThisWorkbook.FollowHyperlink FolderPath
    
End Sub

---

对于targetWorkbook中的每个ws，此处出现错误突出显示

对于targetWorkbook中的每个ws，将其更改为

。工作表

。也无需在循环中使用

Application.DisplayAlerts=True/False

或

Set targetWorkbook=Nothing

）您可能还想了解如何使用

事件

好了，我们已经克服了这个错误@悉达多，谢谢你。但是，现在代码打开第一个文件，并在需要使用Windows任务管理器停止的同一文件上进入无限循环。如果您使用的是

filePath=Dir

BTW

Set-targetWorkbook=Workbooks.Open（Filename:=filePath）

应该是

Set-targetWorkbook=Workbooks.Open（Filename:=folderPath&filePath）

VBASIC208。感谢您抽出时间提供此解决方案。我按照您的指示编辑了文件夹路径（我的原始代码在文件夹路径的末尾也有一个“/”），并运行了它。然而，它总是在线路上抛出一个错误。Dim arl As Object:Set arl=CreateObject（“System.Collections.ArrayList”）。我已经添加了字典解决方案。你可以试一试。谢谢你加上这个。我很感激你在这方面花时间。我正在尝试你建议的修改。似乎正在工作，但我将在文件夹完成后更新。感谢您花时间评估此问题。我以为我自己就快搞定了，但唉，我离这有点远了。这个解决方案非常有效。保存它以备将来使用。非常感谢你！事实上，晚发现。此解决方案删除工作表，但使用第一个工作簿中的内容，并在重新创建后覆盖每个后续工作簿中的内容