Unprotecting multiple Excel files (2,400) that has same password using VBA

[Cliff_Chism]

Hello everyone, I need help. I have 2,470 excel files in 1 folder. They all have only 1 page/tab in each file and all have the same password "oil". I need to unprotect them all. I have a VBA code that I found online to run but it isn't working properly, it "runs" 639 but it doesn't unprotect them. I am not sure what it is doing but it is running and it creates a backup which I really don't need a back of. I have to compile data from 5 years by copying from each PO to enter into another file to have a sheet to be able to filter. This will save me an incredible amount of time when adding up over 2,400 files to unprotect. Below is the code that isn't working. This is the 1st time I have ever tried to use and run VBA. I greatly appreciate any and all help, direction and advice. Thank you in advance

Sub RemovePasswords()
Dim xlBook As Workbook
Dim strFilename As String
Const fPath As String = "C:\Users\BlackBay OA\Desktop\Past PO 2013-2017\" 'The folder to process, must end with "\"
Const strPassword As String = "oil" 'case sensitive
Const strEditPassword As String = """" '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

 

[GWteB]

Hi @Cliff_Chism, welcome to this forum!

Some amendments to your code results in the code below. Since accessing data on disk is by definition a relatively slow process, please bear in mind that the modification of >2K number of files will take quite some time. I would advise you to paste the code below in a code module of a new workbook. This workbook should then be saved as an Excel Macro-Enabled Workbook ( *.xlsm).
Be sure not placing this workbook in the same folder as those >2K workbooks.
Note that the code stops when a worksheet is edited. Therefore, each changed file is subsequently moved to another folder of your choice. That way, the files that have already been processed are skipped when the code is run again. Progress will be displayed on Excel's status bar. Hopefully this suits your requirements.

Public Sub RemovePasswords()

    Dim xlBook      As Workbook
    Dim sht         As Worksheet
    Dim FileName    As String
    Dim FullName    As String
    Dim FileCount   As Long
    Dim ProcCount   As Long

    Const FILESPEC          As String = "F:\SomeFolder\*.xls?"          ' <<  change drive and folder path to suit
    Const NEWPATH           As String = "F:\SomeFolder\PROCESSED\"      ' <<  change to suit; target folder must exist; string must end with "\"

    Const PASSWORD          As String = "oil"   'case sensitive
    Const EDITPASSWORD      As String = """"    'If no password use""

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    ' retrieve number of workbooks to be processed
    FileName = Dir$(FILESPEC)
    While Len(FileName) > 0
        FileCount = FileCount + 1
        FileName = Dir$()
    Wend

    ' process each workbook, one at a time
    FileName = Dir$(FILESPEC)
    While Len(FileName) > 0
        FullName = PathFromFullName(FILESPEC) & FileName
        ProcCount = ProcCount + 1
        Application.StatusBar = "Processing file " & ProcCount & " of " & FileCount & ": " & FullName
        Set xlBook = Workbooks.Open(FileName:=FullName, PASSWORD:=PASSWORD, WriteResPassword:=EDITPASSWORD)

        For Each sht In xlBook.Worksheets
            sht.Unprotect PASSWORD
            sht.Visible = xlSheetVisible
        Next sht

        xlBook.SaveAs FileName:=FullName, PASSWORD:="", WriteResPassword:="", CreateBackup:=False
        xlBook.Close False

        ' move file
        Name FullName As NEWPATH & FileName
        FileName = Dir$()
        VBA.DoEvents
    Wend

SUB_EXIT:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.StatusBar = False
End Sub


Public Function PathFromFullName(ByVal argFullName As String) As String
    PathFromFullName = Left(argFullName, InStrRev(argFullName, "\"))
End Function

 

[Cliff_Chism]

Thank you soooo very much. I will give it a try when I get back to work.

 

[Cliff_Chism]

Good afternoon GWteB, I tried but I get a compile error type mismatch. I am sure I am messing something up since this is the 1st time ever dealing with VBA / code. I am probably using the wrong terms to even describe it LOl. I know I need to take some Excel classes and will soon. Attached is the 2 pics of what I am getting. and here is what I pasted into the module. Please don't get aggrivated/angry with my lack of knowledge with Excel. I understand if I am a little much to deal with. Thank you for helping me out.


Public Sub RemovePasswords()



Dim xlBook As Workbook

Dim sht As Worksheet

Dim FileName As String

Dim FullName As String

Dim FileCount As Long

Dim ProcCount As Long



Const FILESPEC As String = " C:\Users\BlackBay OA\Desktop\Past PO 2013-2017\*.xls?" ' << change drive and folder path to suit

Const NEWPATH As String = " C:\Users\BlackBay OA\Desktop\Processed Past PO” \" ' << change to suit; target folder must exist; string must end with "\"



Const PASSWORD As String = "oil" 'case sensitive

Const EDITPASSWORD As String = """" 'If no password use""



Application.DisplayAlerts = False

Application.ScreenUpdating = False

Application.EnableEvents = False



' retrieve number of workbooks to be processed

FileName = Dir$(FILESPEC)

While Len(FileName) > 0

FileCount = FileCount + 1

FileName = Dir$()

Wend



' process each workbook, one at a time

FileName = Dir$(FILESPEC)

While Len(FileName) > 0

FullName = PathFromFullName(FILESPEC) & FileName

ProcCount = ProcCount + 1

Application.StatusBar = "Processing file " & ProcCount & " of " & FileCount & ": " & FullName

Set xlBook = Workbooks.Open(FileName:=FullName, PASSWORD:=PASSWORD, WriteResPassword:=EDITPASSWORD)



For Each sht In xlBook.Worksheets

sht.Unprotect PASSWORD

sht.Visible = xlSheetVisible

Next sht



xlBook.SaveAs FileName:=FullName, PASSWORD:="", WriteResPassword:="", CreateBackup:=False

xlBook.Close False



' move file

Name FullName As NEWPATH & FileName

FileName = Dir$()

VBA.DoEvents

Wend



SUB_EXIT:

Application.DisplayAlerts = True

Application.ScreenUpdating = True

Application.EnableEvents = True

Application.StatusBar = False

End Sub





Public Function PathFromFullName(ByVal argFullName As String) As String

PathFromFullName = Left(argFullName, InStrRev(argFullName, "\"))

End Function

 

[GWteB]

No need for apologies, each of us was once a newbie. As for your issue, this is caused because VBA can't compile the code into code that the computer understands. This is caused by a typo in the code.

Some clarification: the statement Const FILESPEC As String specifies that we are declaring a constant called FILESPEC of memory type String.
A constant is assigned just once a value (which is to the right of the = sign) which cannot be changed during run-time (unlike a variable whose value can change during run-time). The memory type String holds (and therefore the compiler expects) text within double quotes, like in your PASSWORD constant. A String may be empty (zero length string, no characters at all). An empty String is declared with two consecutive double quotes.
If within a text (for example due to a screen message or for some other reason) one or more double quotes are desired, then we have to let the compiler know with an extra double quote, like in the EDITPASSWORD constant which consist of four double quotes, resulting in two consecutive double quotes after compilation / during run-time.

A closer look at both the FILESPEC and NEWPATH constant in the by you amended code reveals the following. The string of characters assigned to the NEWPATH constant contains not two but three double quotes. Here the compiler revolts with a type mismatch because it does not match the conditions of a valid String type.

In addition to that please note the following. As should be obvious, the value (i.e. string) of both constants are going to be used by the file system so the file system must be able to handle it. For example, names of folders and files must be spelled correctly as they appear on disk. There isn't a single file or folder whose name starts or ends with a space, this is where the file system is definitely going to argue about, i.e. giving you an error message in run-time. So please avoid leading and trailing spaces in a path specification.

In summary, a valid declaration of both constants looks like below.
Note that text displayed in code panes on this board can be copied easily using the upper right hand Copy to clipboard icon.

Const FILESPEC As String = "C:\Users\BlackBay OA\Desktop\Past PO 2013-2017\*.xls?"
Const NEWPATH  As String = "C:\Users\BlackBay OA\Desktop\Processed Past PO\"

 

[Cliff_Chism]

Good afternoon GWteB, I tried but I get a compile error type mismatch. I am sure I am messing something up since this is the 1st time ever dealing with VBA / code. I am probably using the wrong terms to even describe it LOl. I know I need to take some Excel classes and will soon. Attached is the 2 pics of what I am getting. and here is what I pasted into the module. Please don't get aggrivated/angry with my lack of knowledge with Excel. I understand if I am a little much to deal with. Thank you for helping me out.


Public Sub RemovePasswords()



Dim xlBook As Workbook

Dim sht As Worksheet

Dim FileName As String

Dim FullName As String

Dim FileCount As Long

Dim ProcCount As Long



Const FILESPEC As String = " C:\Users\BlackBay OA\Desktop\Past PO 2013-2017\*.xls?" ' << change drive and folder path to suit

Const NEWPATH As String = " C:\Users\BlackBay OA\Desktop\Processed Past PO” \" ' << change to suit; target folder must exist; string must end with "\"



Const PASSWORD As String = "oil" 'case sensitive

Const EDITPASSWORD As String = """" 'If no password use""



Application.DisplayAlerts = False

Application.ScreenUpdating = False

Application.EnableEvents = False



' retrieve number of workbooks to be processed

FileName = Dir$(FILESPEC)

While Len(FileName) > 0

FileCount = FileCount + 1

FileName = Dir$()

Wend



' process each workbook, one at a time

FileName = Dir$(FILESPEC)

While Len(FileName) > 0

FullName = PathFromFullName(FILESPEC) & FileName

ProcCount = ProcCount + 1

Application.StatusBar = "Processing file " & ProcCount & " of " & FileCount & ": " & FullName

Set xlBook = Workbooks.Open(FileName:=FullName, PASSWORD:=PASSWORD, WriteResPassword:=EDITPASSWORD)



For Each sht In xlBook.Worksheets

sht.Unprotect PASSWORD

sht.Visible = xlSheetVisible

Next sht



xlBook.SaveAs FileName:=FullName, PASSWORD:="", WriteResPassword:="", CreateBackup:=False

xlBook.Close False



' move file

Name FullName As NEWPATH & FileName

FileName = Dir$()

VBA.DoEvents

Wend



SUB_EXIT:

Application.DisplayAlerts = True

Application.ScreenUpdating = True

Application.EnableEvents = True

Application.StatusBar = False

End Sub





Public Function PathFromFullName(ByVal argFullName As String) As String

PathFromFullName = Left(argFullName, InStrRev(argFullName, "\"))

End Function

I can not thank you enough!!!! It worked perfectly. You were correct, it took about 2 hours to run through it but I figured That it saved me close to 10 hrs from manually doing it. Like I said I can't thank you enough! Just know that you have at least 1 person in the world that looks and considers you a hero!!!! Thank you, Thankyou, Thank you AGAIN!!!!!!

 

[GWteB]

My pleasure and thanks for the feedback.