Applied this macro to delete empty excel files in a folder

P

Prasad K

Board Regular
Joined
Aug 4, 2021
Messages
189
Office Version
  1. 2016
  2. 2007
Platform
  1. Windows
Hi Excel Experts
I have applied this VBA macro to delete empty excel files in a folder path

This VBA macro is working in my excel 2007 version
Here when I applied this macro in my another pc of excel 2016 version

Then this VBA macro is not deleting any empty excel files in that folder path i have given


And one more query
How to add multiple excel extension in this macro




VBA Code: 
Sub DeleteEmptyFiles()
 Dim FolderPath As String, Filename As String, wb As Workbook
 Dim ws As Worksheet, boolNotEmpty As Boolean
 Dim previousSecurity As MsoAutomationSecurity

 FolderPath = "Enter the folder path here" 'Take care to end the folder path in "\"
                                           'Otherwise, build the file full name inserting "\"
 Filename = Dir(FolderPath & "*.xlsm*")

 Do While Filename <> ""
    previousSecurity = Application.AutomationSecurity
    Application.AutomationSecurity = msoAutomationSecurityForceDisable
    Set wb = Workbooks.Open(Filename:=FolderPath & Filename)
    Application.AutomationSecurity = previousSecurity
    
    boolNotEmpty = False
    For Each ws In wb.Worksheets
        If WorksheetFunction.CountA(ws.UsedRange) > 0 Then
            boolNotEmpty = True: Exit For
        End If
    Next ws
    wb.Close False
    If Not boolNotEmpty Then Kill FolderPath & Filename
    Filename = Dir()
 Loop
End Sub
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
Sort by date Sort by votes
I'd put a file extension function to check the extension first if it is xlsx or xls (whatever)
VBA Code: 
Sub DeleteEmptyFiles()
 Dim FolderPath As String, Filename As String, wb As Workbook
 Dim ws As Worksheet, boolNotEmpty As Boolean
 Dim previousSecurity As MsoAutomationSecurity

 FolderPath = "C:\Users\muhdzaki\Desktop\MrExcel\Test\"
                                           'Otherwise, build the file full name inserting "\"
 Filename = Dir(FolderPath)

 Do While Filename <> ""
 
    If RightExt(Filename) Then
   
    previousSecurity = Application.AutomationSecurity
    Application.AutomationSecurity = msoAutomationSecurityForceDisable
    Set wb = Workbooks.Open(Filename:=FolderPath & Filename)
    Application.AutomationSecurity = previousSecurity
   
    boolNotEmpty = False
    For Each ws In wb.Worksheets
        If WorksheetFunction.CountA(ws.UsedRange) > 0 Then
            boolNotEmpty = True: Exit For
        End If
    Next ws
    wb.Close False
    If Not boolNotEmpty Then Kill FolderPath & Filename

    End If

    Filename = Dir()
 
Loop
End Sub

Function RightExt(MyFile As Variant) As Boolean

Dim ExtX
Dim Arr() As Variant
Dim lngLoc As Variant

RightExt = False
ExtX = Mid(MyFile, InStrRev(MyFile, ".") + 1)
Arr = Array("xls", "xlsx") 'put extension you want to allow here
On Error Resume Next
lngLoc = Application.WorksheetFunction.Match(ExtX, Arr(), 0)
If Not IsEmpty(lngLoc) Then RightExt = True

End Function
 
Upvote 0
Zot said:
I'd put a file extension function to check the extension first if it is xlsx or xls (whatever)
VBA Code: 
Sub DeleteEmptyFiles()
 Dim FolderPath As String, Filename As String, wb As Workbook
 Dim ws As Worksheet, boolNotEmpty As Boolean
 Dim previousSecurity As MsoAutomationSecurity

 FolderPath = "C:\Users\muhdzaki\Desktop\MrExcel\Test\"
                                           'Otherwise, build the file full name inserting "\"
 Filename = Dir(FolderPath)

 Do While Filename <> ""
 
    If RightExt(Filename) Then
  
    previousSecurity = Application.AutomationSecurity
    Application.AutomationSecurity = msoAutomationSecurityForceDisable
    Set wb = Workbooks.Open(Filename:=FolderPath & Filename)
    Application.AutomationSecurity = previousSecurity
  
    boolNotEmpty = False
    For Each ws In wb.Worksheets
        If WorksheetFunction.CountA(ws.UsedRange) > 0 Then
            boolNotEmpty = True: Exit For
        End If
    Next ws
    wb.Close False
    If Not boolNotEmpty Then Kill FolderPath & Filename

    End If

    Filename = Dir()
 
Loop
End Sub

Function RightExt(MyFile As Variant) As Boolean

Dim ExtX
Dim Arr() As Variant
Dim lngLoc As Variant

RightExt = False
ExtX = Mid(MyFile, InStrRev(MyFile, ".") + 1)
Arr = Array("xls", "xlsx") 'put extension you want to allow here
On Error Resume Next
lngLoc = Application.WorksheetFunction.Match(ExtX, Arr(), 0)
If Not IsEmpty(lngLoc) Then RightExt = True

End Function
Click to expand...
Thankyou

I will try this code and tell you
 
Upvote 0
Zot said:
I'd put a file extension function to check the extension first if it is xlsx or xls (whatever)
VBA Code: 
Sub DeleteEmptyFiles()
 Dim FolderPath As String, Filename As String, wb As Workbook
 Dim ws As Worksheet, boolNotEmpty As Boolean
 Dim previousSecurity As MsoAutomationSecurity

 FolderPath = "C:\Users\muhdzaki\Desktop\MrExcel\Test\"
                                           'Otherwise, build the file full name inserting "\"
 Filename = Dir(FolderPath)

 Do While Filename <> ""
 
    If RightExt(Filename) Then
  
    previousSecurity = Application.AutomationSecurity
    Application.AutomationSecurity = msoAutomationSecurityForceDisable
    Set wb = Workbooks.Open(Filename:=FolderPath & Filename)
    Application.AutomationSecurity = previousSecurity
  
    boolNotEmpty = False
    For Each ws In wb.Worksheets
        If WorksheetFunction.CountA(ws.UsedRange) > 0 Then
            boolNotEmpty = True: Exit For
        End If
    Next ws
    wb.Close False
    If Not boolNotEmpty Then Kill FolderPath & Filename

    End If

    Filename = Dir()
 
Loop
End Sub

Function RightExt(MyFile As Variant) As Boolean

Dim ExtX
Dim Arr() As Variant
Dim lngLoc As Variant

RightExt = False
ExtX = Mid(MyFile, InStrRev(MyFile, ".") + 1)
Arr = Array("xls", "xlsx") 'put extension you want to allow here
On Error Resume Next
lngLoc = Application.WorksheetFunction.Match(ExtX, Arr(), 0)
If Not IsEmpty(lngLoc) Then RightExt = True

End Function
Click to expand...
This code is not working

this vba is not deleting any empty excel files in a folder path


VBA Code: 
Sub DeleteEmptyFiles()
 Dim FolderPath As String, Filename As String, wb As Workbook
 Dim ws As Worksheet, boolNotEmpty As Boolean
 Dim previousSecurity As MsoAutomationSecurity

 FolderPath = "C:\Users\Prasad\Desktop\Excel Files\"
                                           'Otherwise, build the file full name inserting "\"
 Filename = Dir(FolderPath)

 Do While Filename <> ""
 
    If RightExt(Filename) Then
   
    previousSecurity = Application.AutomationSecurity
    Application.AutomationSecurity = msoAutomationSecurityForceDisable
    Set wb = Workbooks.Open(Filename:=FolderPath & Filename)
    Application.AutomationSecurity = previousSecurity
   
    boolNotEmpty = False
    For Each ws In wb.Worksheets
        If WorksheetFunction.CountA(ws.UsedRange) > 0 Then
            boolNotEmpty = True: Exit For
        End If
    Next ws
    wb.Close False
    If Not boolNotEmpty Then Kill FolderPath & Filename

    End If

    Filename = Dir()
 
Loop
End Sub

Function RightExt(MyFile As Variant) As Boolean

Dim ExtX
Dim Arr() As Variant
Dim lngLoc As Variant

RightExt = False
ExtX = Mid(MyFile, InStrRev(MyFile, ".") + 1)
Arr = Array("xlsm", "xlsx") 'put extension you want to allow here
On Error Resume Next
lngLoc = Application.WorksheetFunction.Match(ExtX, Arr(), 0)
If Not IsEmpty(lngLoc) Then RightExt = True

End Function
 
Upvote 0
I was just showing how you can add several extension instead of one extension like xls and xlsx instead of just xls in the example. I misread your statement. I thought you were able to delete empty file but just want to add more extension ?
 
Upvote 0
Try this but back-up your files first. This is using file size. Usually blank xls file is less than 8kB. However if it is macro file with module but no code and also no contents, then the file is still more than 8kB.

You need to investigate further. This is one of the method you can use to find empty file.

VBA Code: 
Sub DeleteEmptyFiles()
 Dim FolderPath As String, Filename As String, wb As Workbook
 Dim ws As Worksheet, boolNotEmpty As Boolean
 Dim previousSecurity As MsoAutomationSecurity

 FolderPath = "C:\<filepathhere>\"
                                           'Otherwise, build the file full name inserting "\"
 Filename = Dir(FolderPath)
 
 Application.ScreenUpdating = False

 Do While Filename <> ""
 
    If RightExt(Filename) Then
   
    previousSecurity = Application.AutomationSecurity
    Application.AutomationSecurity = msoAutomationSecurityForceDisable
    Set wb = Workbooks.Open(Filename:=FolderPath & Filename)
    Application.AutomationSecurity = previousSecurity
   
    If FileLen(Filename) > 8000 Then
        boolNotEmpty = True
    Else
        boolNotEmpty = False
    End If
    wb.Close False
    If Not boolNotEmpty Then Kill FolderPath & Filename

    End If

    Filename = Dir()
 
Loop
End Sub

Function RightExt(MyFile As Variant) As Boolean

Dim ExtX
Dim Arr() As Variant
Dim lngLoc As Variant

RightExt = False
ExtX = Mid(MyFile, InStrRev(MyFile, ".") + 1)
Arr = Array("xls", "xlsx") 'put extension you want to allow here
On Error Resume Next
lngLoc = Application.WorksheetFunction.Match(ExtX, Arr(), 0)
If Not IsEmpty(lngLoc) Then RightExt = True

End Function
 
Upvote 0
Prasad K said:
when i run this code i have get run time error 53

this one line of code highlighted in yellow color
Click to expand...
that is file Not Found error.. Make sure you have the right path.
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Question
VBA to import multilpe xml files
Replies
1
Views
46
PippaThePointer
P
C
  • Solved
Macro works for one file, does not work for all files in the directory
2
Replies
13
Views
487
Alex Blakenburg
A
J
  • Question
VBA Script - Can't figure out one error...
2
Replies
15
Views
242
Peter_SSs
Peter_SSs
J
  • Question
Power Query - Data Refresh Error in Macro
Replies
3
Views
134
bobsan42
bobsan42
G
  • Question
Open workbooks in folder and run Macro in each book
Replies
7
Views
366
glynn1969
G

Forum statistics

Threads
1,215,002
Messages
6,122,652
Members
449,092
Latest member
peppernaut

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top