CODEWITHSUNDEEP
excelvba
Franco Onorati
Franco Onorati

Reputation: 3

VBA - Skip corrupted files

I copied code from another site that opens every Excel file on a path and sets the password to "".

I have 480 Excel files on that path, and the code stops whenever it encounters a corrupted file.

Sub RemovePasswords()
    Dim xlBook As Workbook
    Dim strFilename As String
    Const fPath As String = "C:\Path\"        'The folder to process, must end with "\"
    Const strPassword As String = "openpassword"        'case sensitive
    Const strEditPassword As String = "editpassword" 'If no password use ""
    
    strFilename = Dir$(fPath & "*.xls") 'will open xls & xlsx etc
    While Len(strFilename) <> 0
        Application.DisplayAlerts = False
        Set xlBook = Workbooks.Open(FileName:=fPath & strFilename, _
                                    Password:=strPassword, _
                                    WriteResPassword:=strEditPassword)
        xlBook.SaveAs FileName:=fPath & strFilename, _
                      Password:="", _
                      WriteResPassword:="", _
                      CreateBackup:=True
        xlBook.Close 0
        Application.DisplayAlerts = True
        strFilename = Dir$()
    Wend
End Sub

On the other hand, whenever the code encounters a corrupted file it just stops and doesn't let me know which file is corrupted.

I know that there is a way to put a "if" to skip this errors, but I don't know how to do it.

Upvotes: 0

Views: 315

Answers (2)

C&#233;sar Rodriguez
C&#233;sar Rodriguez

Reputation: 430

I would change the code suggested by FaneDuru a little, in order to comply to your first demand. This code will output corrupt filenames in the debug panel.

Sub RemovePasswords()
    Dim xlBook As Workbook
    Dim strFilename As String
    Const fPath As String = "C:\Path\" 'The folder to process, must end with "\"
    Const strPassword As String = "openpassword" 'case sensitive
    Const strEditPassword As String = "editpassword" 'If no password use ""
    
    strFilename = Dir$(fPath & "*.xls") 'will open xls & xlsx etc
    Application.DisplayAlerts = False
    On Error Resume Next
    While Len(strFilename) <> 0        
        Set xlBook = Workbooks.Open(FileName:=fPath & strFilename, _
            Password:=strPassword, WriteResPassword:=strEditPassword)
        If err.Number = 0 Then
            xlBook.SaveAs FileName:=fPath & strFilename, _
                Password:="", WriteResPassword:="", CreateBackup:=True
            xlBook.Close 0
        Else
            Debug.Print strFilename 'This will output corrupt filenames in the debug pane
            err.Clear
        End If
        strFilename = Dir$()
    Wend
    On Error GoTo 0
    Application.DisplayAlerts = True
End Sub

Upvotes: 0

FaneDuru
FaneDuru

Reputation: 42236

Please, try the next adapted code:

Sub RemovePasswords()
Dim xlBook As Workbook, strFilename As String
Const fPath As String = "C:\Path\"               'The folder to process, must end with "\"
Const strPassword As String = "openpassword"     'case sensitive
Const strEditPassword As String = "editpassword" 'If no password use ""
    strFilename = dir$(fPath & "*.xls")          'will open xls & xlsx etc
    While Len(strFilename) <> 0
        On Error Resume Next 'skip the error, if the case
        Set xlBook = Workbooks.Open(fileName:=fPath & strFilename, _
                                    password:=strPassword, _
                                    WriteResPassword:=strEditPassword)
        If err.Number = 0 Then                 'if no error:
            Application.DisplayAlerts = False
            xlBook.saveas fileName:=fPath & strFilename, _
                          password:="", _
                          WriteResPassword:="", _
                          CreateBackup:=True
            xlBook.Close 0
            Application.DisplayAlerts = True
        End If
        On Error GoTo 0                     'restart raising errors when the case
        strFilename = dir$()
    Wend
End Sub

Upvotes: 1

Related Questions