时间戳

首页 > 解决方案 > VBA 循环目录从每个工作簿中删除（按工作表名称）除一个之外的所有工作表

excel - VBA 循环目录从每个工作簿中删除（按工作表名称）除一个之外的所有工作表

问题描述

我之前在这里发布过关于使用 VBA 循环浏览文件夹并从其中的每个工作簿中删除已知密码的信息。以为我可以使用相同的代码，只需插入代码即可删除除一张以外的所有工作表（通过引用工作表名称），但没有这样的运气。

有任何 VBA 专业人士可以提供帮助吗？

Sub loop_sheets_del()

Dim MyFile as String, str As String, MyDir = "[directory]"
MyFile = Dir(MyDir & "*.xlsx")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0

Do While Myfile <> ""
Workbooks.Open (MyFile)
If ws.Name <> "name of sheet to keep" Then
ws.Delete
End If

Next ws (error indicates problem is here)

ActiveWorkbook.Close True
End With
MyFile = Dir()
Loop

End Sub

标签： excelvbaloops

解决方案

删除表格

  • 在当前设置中，以下将删除指定文件夹及其所有子文件夹Master中所有xls*扩展名为（例如xls，，xlsx：xlsm不要在代码中使用通配符；它被 覆盖）中命名的工作表之外的所有工作表。InstrF:\Test\2020\64504925

编码

Option Explicit

' Run only this sub after you have adjusted the path, the worksheet name
' and the file extension.
Sub loopSubFolders()
    
    Application.ScreenUpdating = False
    
    loopSubFoldersInitialize "F:\Test\2020\64504925", "Master", "xls"
    
    Application.ScreenUpdating = True
    
    MsgBox "Sheets deleted.", vbInformation, "Success"

End Sub

Sub loopSubFoldersInitialize(ByVal FolderPath As String, _
                             ByVal SheetName As String, _
                             Optional ByVal FileExtension As String = "")
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    loopSubFoldersRecursion fso, fso.GetFolder(FolderPath), SheetName, _
                            FileExtension
End Sub

Sub loopSubFoldersRecursion(fso As Object, _
                            fsoFolder As Object, _
                            ByVal SheetName As String, _
                            Optional ByVal FileExtension As String = "")

    Dim fsoSubFolder As Object
    Dim fsofile As Object
    
    For Each fsoSubFolder In fsoFolder.SubFolders
        loopSubFoldersRecursion fso, fsoSubFolder, SheetName, FileExtension
    Next
    
    If FileExtension = "" Then
        For Each fsofile In fsoFolder.Files
            'Debug.Print fsofile.Path
        Next
    Else
        For Each fsofile In fsoFolder.Files
            If InStr(1, fso.GetExtensionName(fsofile.Path), _
                     FileExtension, vbTextCompare) > 0 Then
                Dim wb As Workbook
                Set wb = Workbooks.Open(fsofile.Path)
                deleteSheetsExceptOneByName wb, SheetName
                Debug.Print fsofile.Path
                wb.Close SaveChanges:=True
            End If
        Next fsofile
    End If

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Deletes all sheets in a workbook except the one specified
'               by its name.
' Remarks:      The code uses the dictionary to hold all the sheet names.
'               Only if the specified sheet exists, it will be removed from
'               the dictionary and the remaining sheets in it will be deleted
'               in one go. Otherwise no action will be taken.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function deleteSheetsExceptOneByName(Book As Workbook, _
                                     ByVal SheetName As String) _
         As Long
    
    ' Initialize error handling.
    Const ProcName As String = "deleteSheetsExceptOneByName"
    On Error GoTo clearError ' Turn on error trapping.

    ' Validate workbook.
    If Book Is Nothing Then
        GoTo NoWorkbook
    End If
    
    ' Define dictionary.
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        ' Write sheet names to dictionary.
        Dim sh As Object
        For Each sh In Book.Sheets
            .Add sh.Name, Empty
        Next sh
        ' Validate sheet name string.
        If Not .Exists(SheetName) Then
            GoTo NoSheet
        End If
        ' Remove sheet name string from the dictionary.
        .Remove (SheetName)
        ' Validate number of sheets.
        If .Count = 0 Then
            GoTo OneSheet
        End If
        ' Delete sheets.
        Application.DisplayAlerts = False
        Book.Sheets(.Keys).Delete
        Application.DisplayAlerts = True
        deleteSheetsExceptOneByName = .Count
        GoTo SheetsDeleted
    End With
    
NoWorkbook:
    Debug.Print "'" & ProcName & "': No workbook ('Nothing')."
    GoTo ProcExit

NoSheet:
    Debug.Print "'" & ProcName & "': No sheet named '" & SheetName _
              & "' in workbook."
    GoTo ProcExit

OneSheet:
    Debug.Print "'" & ProcName & "': Sheet '" & Book.Sheets(SheetName).Name _
              & "' is the only sheet in workbook."
    GoTo ProcExit

SheetsDeleted:
    If deleteSheetsExceptOneByName > 1 Then
        Debug.Print "'" & ProcName & "': Deleted " _
                  & deleteSheetsExceptOneByName & " sheets in workbook."
    Else
        Debug.Print "'" & ProcName & "': Deleted 1 sheet in workbook."
    End If
    GoTo ProcExit

clearError:
    Debug.Print "'" & ProcName & "': " & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    On Error GoTo 0 ' Turn off error trapping.
    GoTo ProcExit

ProcExit:

End Function

推荐阅读