Merging Multiple Workbooks into One With Individual Passwords

[greenhillchris]

Hi

I have the following code that opens each individual password protected workbook that’s in a folder and combines the first sheet into 1 workbook, I currently have 20 workbooks that I am combining and using an array loop to find the password for each workbook.

Sub ConslidateWorkbooksPasswords()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Dim Path As String
Dim Filename As String
Dim Sheet As Worksheet
Dim item As Variant
Dim list As Variant

list = Array("PW", "PW", "PW", "PW", "PW", "PW", "PW", "PW", "PW", "PW", "PW", "PW", "PW", "PW", "PW", "PW", "PW", "PW", "PW", "PW") 'PW are not the actual individual passwords I have for my 20 workbooks, just wanted to show how I have my passwords


Path = "My folder path" 'Name is not my actual folder path
Filename = Dir(Path & "*.xlsx")
Do While Filename <> ""

For Each item In list
On Error Resume Next

Workbooks.Open Filename:=Path & Filename, Password:=item, ReadOnly:=True
If Err.Number <> 0 Then GoTo Copyandpaste:
Exit For

Copyandpaste:
Next item

    For Each Sheet In ActiveWorkbook.Sheets
        Sheet.Copy After:=ThisWorkbook.Sheets(1)
    Next Sheet

Workbooks(Filename).Close

Filename = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
End Sub

This works great however I am soon having to combine 190 workbooks and I am thinking this code will be sluggish to loop around that many individual passwords.
I am thinking of having a separate sheet with passwords in column A and a direct path to each workbook in column B.

Would this be the best option and how would I amend this code to reflect this or is there a simpler way of doing this?

Appreciate any help here

Thanks

 

[greenhillchris]

Hi

I have managed to amend my code above so the direct path to each file is in a range within a worksheet along with the passwords.

Sub ConslidateWorkbooksWithPasswords()

Dim Sheet As Worksheet
Dim documents As Range, wb As Range
Dim Filename As String

Set documents = ActiveSheet.Range("C2:C21") 


With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .EnableEvents = False
    .AskToUpdateLinks = False
    .DisplayStatusBar = False
End With

For Each wb In documents

Workbooks.Open Filename:=wb, Password:=wb.Offset(, -1), ReadOnly:=True

Next

     For Each Sheet In ActiveWorkbook.Sheets
        Sheet.Copy After:=ThisWorkbook.Sheets(2)
    Next Sheet
   

Workbooks(wb).Close
Filename = wb

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .EnableEvents = True
    .AskToUpdateLinks = True
    .DisplayStatusBar = True
End With

End Sub

This works and opens all the workbooks and then it starts to copy the sheets from each open workbook, it does this for one open workbook and then I am getting runtime error 13 type mismatch for this part of the code when it tries to close

Workbooks(wb).Close

I removed this part and ran it again, I didnt get the error this time however it still only copied only one of the open workbooks and not all of them like my previous code did.

Where am I going wrong?

Thanks