Excel工作簿的VBA循环文件夹，并删除除一张纸外的所有文件

debugcn 发表于 Dev

约翰·泰勒

尝试将一些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

悉达思·劳特

对于targetWorkbook中的每个ws在这里发生错误突出显示将其更改为targetWorkbook.Worksheets中的每个ws。同样也不需要使用Application.DisplayAlerts = True / False或Set targetWorkbook =循环中没有任何内容；）您可能还想看看优化VBA代码并提高如何使用事件的性能– Siddharth Rout 21分钟前

顺便说一句Set TargetWorkbook = Workbooks.Open（Filename：= filePath）应该设置Set TargetWorkbook = Workbooks.Open（Filename：= 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

本文收集自互联网，转载请注明来源。

如有侵权，请联系[email protected] 删除。