rockybalboa
01-05-2017, 01:13 AM
Hi,
I have around 8 excel files in a folder of which some files (around 4) are password protected. I am looking for a way to open the password protected files via macro. I have the passwords for all of them.
Below is my code
Sub Run()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
myPath = "D:\My\Team\"
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xlsm"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile) '(How to open some of the password protected workbooks?)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Collate
wb.Sheets("Board").Select
Range("H8:L8").Select
Selection.Copy
ThisWorkbook.Activate
Sheets("Team").Select
Range("B1000").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues
'Close Workbook
wb.Close SaveChanges:=False
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Thanks for your help.
I have around 8 excel files in a folder of which some files (around 4) are password protected. I am looking for a way to open the password protected files via macro. I have the passwords for all of them.
Below is my code
Sub Run()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
myPath = "D:\My\Team\"
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xlsm"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile) '(How to open some of the password protected workbooks?)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Collate
wb.Sheets("Board").Select
Range("H8:L8").Select
Selection.Copy
ThisWorkbook.Activate
Sheets("Team").Select
Range("B1000").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues
'Close Workbook
wb.Close SaveChanges:=False
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Thanks for your help.