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

willow1985

Well-known Member
Joined
Jul 24, 2019
Messages
633
Office Version
  1. 2019
Platform
  1. Windows
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! :)

1595450528011.png


VBA Code:
'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
 

Some videos you may like

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
Change this line:
Set wb = Workbooks.Open(Filename:=myPath & myFile)

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

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
I'm glad to help you. Thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,113,907
Messages
5,544,984
Members
410,647
Latest member
LegenDSlayeR
Top