Please help me make this code more efficient!

[kcmj000]

Hi Excel Experts,

I'm trying to create a code in VBA to help reduce the size of thousands of files that were saved throughout the years. To do so, I need the code to go through each file, paste values the worksheets we need to retain, and delete the other worksheets that we no longer need. I am not familiar with VBA, so I pulled together this code below using multiple sources on Google. This code does work, but I'm hoping to see if you all have any suggestions on how to make it run faster (it currently completes 2 to 3 files per minute). Thanks so much in advance!

Sub DownsizeAnalysisFile()

Dim strPath As String
Dim strExtension As String
Dim wbOpen As Workbook
Dim ws As Worksheet 'newly added
Application.ScreenUpdating = False
strPath = "folder location" '<---- Change to folder with files
strExtension = Dir(strPath & "*.xlsm")
Do While strExtension <> ""
Set wbOpen = Workbooks.Open(strPath & strExtension)
Application.DisplayAlerts = False
wbOpen.Sheets("Data Input").Select
On Error Resume Next
wbOpen.Sheets("Data Input").ShowAllData
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

wbOpen.Sheets("Peer Ee Review1").Select 'Ideally, would like to apply these same actions to all worksheets with names containing "Peer Ee Review1"
On Error Resume Next
wbOpen.Sheets("Peer Ee Review1").AutoFilter.ShowAllData
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

On Error Resume Next
wbOpen.Sheets("Peer Ee Review1 (2)").Select
On Error Resume Next
wbOpen.Sheets("Peer Ee Review1 (2)").AutoFilter.ShowAllData
On Error Resume Next
Cells.Select
On Error Resume Next
Application.CutCopyMode = False
On Error Resume Next
Selection.Copy
On Error Resume Next
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

wbOpen.Sheets("Deliverable-Single Ee Request").Delete
wbOpen.Sheets("Deliverable-Multi Ee Request").Delete
wbOpen.Sheets("Deliverable-ExternalHireRequest").Visible = True
wbOpen.Sheets("Deliverable-ExternalHireRequest").Delete
wbOpen.Sheets("Dataset Conversion").Visible = True
wbOpen.Sheets("Dataset Conversion").Delete
wbOpen.Sheets("All Ee Data").Delete
wbOpen.Sheets("Drop-Downs & Lookup Tables").Delete


wbOpen.Save: wbOpen.Close
Application.DisplayAlerts = True
strExtension = Dir
Loop
Application.ScreenUpdating = True


End Sub

 

[rlv01]

Perhaps something like this. (NOT TESTED)

Sub DownsizeAnalysisFile()
    
    Dim fname As String, DirName As String, Ext As String
    Dim FSO As Object, FFolder As Object, FFile As Object
    Dim WBOpen As Workbook
    Dim WS As Worksheet 'newly added
    
    
    DirName = "folder location" '<---- Change to folder with files
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Application.ScreenUpdating = False
    If FSO.FolderExists(DirName) Then
        Set FFolder = FSO.GetFolder(DirName)
        
        Application.DisplayAlerts = False
        For Each FFile In FFolder.Files
            fname = FFile.Name
            Ext = FSO.GetExtensionName(FFile.Path)
            
            Select Case UCase(Ext)
                Case "XLSM", "XLSX"
                    Set WBOpen = Workbooks.Open(FFile.Path)
                    
                    For Each WS In WBOpen.Worksheets
                        Select Case Trim(Left(WS.Name, 15))
                            Case "Data Input", "Peer Ee Review1"
                                With WS
                                    .ShowAllData
                                    .UsedRange.Value = .UsedRange.Value
                                End With
                        End Select
                        
                        Select Case WS.Name
                            Case "Deliverable-Single Ee Request", _
                                "Deliverable-Multi Ee Request", _
                                "Deliverable-ExternalHireRequest", _
                                "Dataset Conversion", "All Ee Data", _
                                "Drop-Downs & Lookup Tables"
                                With WS
                                    .Visible = xlSheetVisible
                                    .Delete
                                End With
                        End Select
                    Next WS
                    
                    WBOpen.Save
                    DoEvents
                    WBOpen.Close
                    DoEvents
            End Select
        Next FFile
        Application.DisplayAlerts = True
    End If
    Application.ScreenUpdating = True
End Sub

 

[kcmj000]

Perhaps something like this. (NOT TESTED)

Sub DownsizeAnalysisFile()
   
    Dim fname As String, DirName As String, Ext As String
    Dim FSO As Object, FFolder As Object, FFile As Object
    Dim WBOpen As Workbook
    Dim WS As Worksheet 'newly added
   
   
    DirName = "folder location" '<---- Change to folder with files
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
   
    Application.ScreenUpdating = False
    If FSO.FolderExists(DirName) Then
        Set FFolder = FSO.GetFolder(DirName)
       
        Application.DisplayAlerts = False
        For Each FFile In FFolder.Files
            fname = FFile.Name
            Ext = FSO.GetExtensionName(FFile.Path)
           
            Select Case UCase(Ext)
                Case "XLSM", "XLSX"
                    Set WBOpen = Workbooks.Open(FFile.Path)
                   
                    For Each WS In WBOpen.Worksheets
                        Select Case Trim(Left(WS.Name, 15))
                            Case "Data Input", "Peer Ee Review1"
                                With WS
                                    .ShowAllData
                                    .UsedRange.Value = .UsedRange.Value
                                End With
                        End Select
                       
                        Select Case WS.Name
                            Case "Deliverable-Single Ee Request", _
                                "Deliverable-Multi Ee Request", _
                                "Deliverable-ExternalHireRequest", _
                                "Dataset Conversion", "All Ee Data", _
                                "Drop-Downs & Lookup Tables"
                                With WS
                                    .Visible = xlSheetVisible
                                    .Delete
                                End With
                        End Select
                    Next WS
                   
                    WBOpen.Save
                    DoEvents
                    WBOpen.Close
                    DoEvents
            End Select
        Next FFile
        Application.DisplayAlerts = True
    End If
    Application.ScreenUpdating = True
End Sub

Hi there rlv01 - thank you very much for your reply. I tried running the code but this step stops the process from continuing: .ShowAllData
Would you know how I can adjust this?

 

[kevin9999]

Try replacing

.ShowAllData

with

If .AutoFilterMode Then .AutoFilter.ShowAllData