Help with VBA code - Open Files as read only and don't update links

[willow1985]

Hello,

I have the below code and what it does is it goes through an entire folder and opens every excel file in that folder and performs a task on it.

Unfortunately a good chunk of these files are password protected and prompt to update links.

Is there a way to modify this code to open all as read only and always say "dont update" ?

I am going through over 400 files and dont want to be clicking on the prompts each time.

Thank you to anyone who can help!

'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com

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

'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
.Title = " VAc Furnace Excel Files"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With

'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"

'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)

'Ensure Workbook has opened before moving on to next line of code
DoEvents

'What to do in each file

Range("B20").Select

ActiveCell.FormulaR1C1 = _

"= MID(CELL(""filename""),SEARCH(""["",CELL(""filename""))+1,SEARCH(""."",CELL(""filename""))-1-SEARCH(""["",CELL(""filename"")))"

Range("B14,B15,B18,B19,B20").Select

Range("B20").Activate

Selection.Copy

Application.WindowState = xlNormal

Windows("VAc Furnace Combined Data.xlsx").Activate

Range("A1").Select

Dim LastRow As Long

LastRow = Cells(Rows.Count, 1).End(xlUp).Row

Cells(LastRow, 1).Offset(1, 0).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=True

Application.WindowState = xlNormal



wb.Worksheets(1).Range("A1:Z1").Interior.Color = RGB(51, 98, 174)

'Close Workbook and do not save
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

 

[DanteAmor]

Change this line:
Set wb = Workbooks.Open(Filename:=myPath & myFile)

For this:
Set wb = Workbooks.Open(Filename:=myPath & myFile, UpdateLinks:=False, ReadOnly:=True)

 

[willow1985]

Worked perfect! Thank you again

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.