Loop excel workbooks in a folder and remove all but one sheet

Question

Tried cobbling together some VBA to accomplish a fairly simple task. Loop through a folder of .xlsx files, open each one, remove all sheets except one with a consistent name in all of the workbooks, save the workbook with the same name.

Here is the code, but keeps throwing an error on

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

`For Each ws In targetWorkbook ERROR HIGHLIGHT OCCURRING HERE` Change it to `For Each ws In targetWorkbook.Worksheets`. Also no need to use `Application.DisplayAlerts = True/False` or `Set targetWorkbook = Nothing` in a loop ;) You may also want to see [Optimizing the VBA Code and improve the performance](https://stackoverflow.com/questions/65284481/optimizing-the-vba-code-and-improve-the-performance) on how to use the `Events` — Siddharth Rout, Jan 19 '21 at 05:24
Well, got past that error. @SiddharthRout so thank you. But, now code opens the first file and enters an infinite loop on that same file that requires stopping with Windows task manager. — John Taylor, Jan 19 '21 at 05:31
BTW `Set targetWorkbook = Workbooks.Open(Filename:=filePath)` should be `Set targetWorkbook = Workbooks.Open(Filename:=folderPath & filePath)` — Siddharth Rout, Jan 19 '21 at 05:43

Siddharth Rout · Answer 1 · 2021-01-19T05:52:57.517

For Each ws In targetWorkbook ERROR HIGHLIGHT OCCURRING HERE Change it to For Each ws In targetWorkbook.Worksheets. Also no need to use Application.DisplayAlerts = True/False or Set targetWorkbook = Nothing in a loop ;) You may also want to see Optimizing the VBA Code and improve the performance on how to use the Events – Siddharth Rout 21 mins ago

BTW Set targetWorkbook = Workbooks.Open(Filename:=filePath) should be Set targetWorkbook = Workbooks.Open(Filename:=folderPath & filePath) – Siddharth Rout 2 mins ago Edit Delete

Based on my comments, try this. I tested it and this works

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

I am trying this modification you suggest now. Appears to be working, but I will update once the folder is complete. Thank you for your time evaluating this issue. I thought I was close to figuring it out on my own, but alas, I was somewhat far off. — John Taylor, Jan 19 '21 at 14:14
This solution worked perfectly. Saving it for future use. Thank you so much! — John Taylor, Jan 19 '21 at 14:49
Actually, late discovery. This solution removes the sheets but uses the content from the first workbook and overwrites the content in each successive workbook after removing its password. So I ended up with a folder of workbook that all has the content from the first workbook. Trying to figure that out. — John Taylor, Jan 21 '21 at 14:11
`This solution removes the sheets but uses the content from the first workbook and overwrites the content in each successive workbook after removing its password.` No you are mistaken. :) It doesn't do that. Do you see me writing anything or doing anything with password? My solution simply loops though the file and deletes the sheet as per your question. I think you have added more code to it which does that :) — Siddharth Rout, Jan 21 '21 at 14:28
You are correct. That bit about the password was an error in my comment. The code removes the correct sheets but does do the rest (the overwriting of all workbook with the data from the first sheet where tabs are removed). My apologies on that error in my comment. — John Taylor, Jan 22 '21 at 05:31
Do you see any part of my code where I am overwriting something? — Siddharth Rout, Jan 22 '21 at 06:48

VBasic2008 · Answer 2 · 2021-01-19T14:35:38.217

`Dir` feat. `ArrayList`

The following will loop through all .xlsx files in a folder, opening each of them, writing each worksheet's name to an Array List, then removing the specified name (case-insensitive) from the list, then deleting the worksheets whose names remained in the list and finally saving the workbook (file).
If a worksheet with the specified name does not exist or it is the only worksheet in the workbook, no action will be taken i.e. the workbook will be closed without saving changes.
Adjust the values in the constants section. Note that in this solution, FolderPath has to end with a backslash (\).

The Code

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

EDIT:

The Dictionary Solution

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

VBasic2008. Thank you for taking the time to offer this solution. I edited the folder path as you indicated (my original code had a "/" at the end of the folder path as well) and ran it. However, it consistently threw an error on the line. Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList"). — John Taylor, Jan 19 '21 at 14:10
I've added the dictionary solution. You might give it a shot. — VBasic2008, Jan 19 '21 at 14:37

Loop excel workbooks in a folder and remove all but one sheet

2 Answers2

Dir feat. ArrayList

`Dir` feat. `ArrayList`