Solved: Open Password Protected Workbooks in VBA

[hobbiton73]

Hi, I wonder whether someone may be able to help me please.

I'm using the code below to consoldiate multiple Excel workbooks into one 'Summary' sheet.

[vba]Sub Merge()
Dim DestWB As Workbook
Dim WB As Workbook
Dim ws As Worksheet
Dim SourceSheet As String
Dim startRow As Long
Dim n As Long
Dim dr As Long
Dim lastRow As Long
Dim FileNames As Variant


Sheets("Input").Range("A7:AE1700").Cells.ClearContents
Set DestWB = ActiveWorkbook

SourceSheet = "Input"
startRow = 7

Application.ScreenUpdating = False

Set WB = ThisWorkbook
FileNames = WB.Worksheets("Lists").Range("B3:B22").Value
For n = LBound(FileNames, 1) To UBound(FileNames, 1)

Set WB = Workbooks.Open(Filename:=FileNames(n, 1), ReadOnly:=True)
For Each ws In WB.Worksheets
Call ShowProgress
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dr = DestWB.Worksheets("Input").Range("C" & DestWB.Worksheets("Input").Rows.Count).End(xlUp).Row + 1
lastRow = .Range("C" & Rows.Count).End(xlUp).Row
If lastRow >= startRow Then
.Range("A" & startRow & ":AE" & lastRow).Copy
DestWB.Worksheets("Input").Cells(dr, "A").PasteSpecial xlValues
End If
End If
End With
Exit For
End If
Next ws
Application.CutCopyMode = False
WB.Close savechanges:=False

Next n
Columns("A:S").EntireColumn.AutoFit
End Sub[/vba]

Using this line, [vba]FileNames = WB.Worksheets("Lists").Range("B3:B22").Value[/vba] the script runs through a list of files opening each one and copying the relevant information before pasting into the 'Destination' file.

The problem I have is that all of the 'Source' files are password protected and because there are approximately 20 of these, to run through each one is quite a laborious task.

I've not been able to find any examples of this, so I'm not sure whether it's possible, but could someone perhaps offer some guidance on how I may be able to adapt the code, so that the script looks through the list in the range "B3:B22" as per the current functionality, but then looks through "C3:C22" for the relevant password.

Any help would be gratefully received.

Many thanks and kind regards

Chris

[p45cal]

try:[VBA]Set WB = Workbooks.Open(Filename:=FileNames(n, 1), ReadOnly:=True, Password:=WB.Worksheets("Lists").Range("C3:C22").Cells(n).Value)
[/VBA]instead of you cuirrent Set WB line.

[hobbiton73]

Hi @p45cal, thank you for taking the time to reply to my post and for putting the solution together.

I've amended this line [vba]Set WB = Workbooks.Open(Filename:=FileNames(n, 1), ReadOnly:=True)[/vba]to
[vba]
Set WB = Workbooks.Open(Filename:=FileNames(n, 1), ReadOnly:=True, Password:=WB.Worksheets("Lists").Range("C3:C22").Cells(n).Value)
[/vba]
The first file correctly opens, copies and pastes the relevant information, but then when the code gors to open the next file I recieve the following error:

Run-time error '-26147221080 Automation error'.

Could you tell me please where I may have gone wrong.

Many thanks and kind regards

Chris

[p45cal]

I see where the problem lies. Change:[VBA]Set WB = ThisWorkbook
FileNames = WB.Worksheets("Lists").Range("B3:B22").Value
For n = LBound(FileNames, 1) To UBound(FileNames, 1)
[/VBA]to:
[VBA] FileNames = Thisworkbook.Worksheets("Lists").Range("B3:B22").Value
For n = LBound(FileNames, 1) To UBound(FileNames, 1) [/VBA]and change the:[VBA]Set WB = Workbooks.Open(Filename:=FileNames(n, 1), ReadOnly:=True, Password:=WB.Worksheets("Lists").Range("C3:C22").Cells(n).Value)[/VBA]to:[VBA]Set WB = Workbooks.Open(Filename:=FileNames(n, 1), ReadOnly:=True, Password:=Thisworkbook.Worksheets("Lists").Range("C3:C22").Cells(n).Value)[/VBA]
(You had used WB for both ThisWorkbook and the Source Workbooks)

[hobbiton73]

Hi @p45cal, thank you very much for your continued help with this.

I've tried your solution and it works perfectly!

Once again, many thanks for all your time and trouble.

Kind regards

Chris