Sub Workplan_Update()
'
' Workplan_Update Macro
'
Sheet1.Unprotect Password:="******"
Application.ScreenUpdating = False
Windows("Workplan.xls").Activate
' Get the path of where the files are stored. That way, the files can be moved to any location and won't need updating
' Removed last 6 characters to drop off Master folder part
nUNCpath = Left(ActiveWorkbook.Path, Len(ActiveWorkbook.Path) - 6)
' Delete existing data from Workbook before updating
Application.ScreenUpdating = False
ActiveCell.SpecialCells(xlLastCell).Select
nLC = ActiveCell.Address
If ActiveCell.Row <> 1 Then
Range("A2", nLC).Select
Selection.Delete
End If
' Select A2 to start process
Range("A2").Select
' repeat for all workbooks in folder
On Error Resume Next
Set wbCodeBook = ThisWorkbook
With Application.FileSearch
.NewSearch
.LookIn = nUNCpath
.FileType = msoFileTypeExcelWorkbooks
'Optional filter with wildcard
.Filename = "*.xls"
If .Execute > 0 Then 'Workbooks in folder
' Check which files are open
cFileList = ""
For lCount = 1 To .FoundFiles.Count 'Loop through all
cCurrentFile = .FoundFiles(lCount)
hdlFile = FreeFile
On Error GoTo FileIsOpen:
Open .FoundFiles(lCount) For Random Access Read Write Lock Read Write As hdlFile
Close hdlFile
GoTo EndLoop
FileIsOpen:
' Someone has it open
cCF = Left(Right(cCurrentFile, Len(cCurrentFile) - Len(nUNCpath)), Len(Right(cCurrentFile, Len(cCurrentFile) - Len(nUNCpath) - 4)))
cFileList = cFileList + cCF + Chr(10)
Close hdlFile
EndLoop:
Next lCount
' Display message and exit macro
MsgBox ("The Following Files Are Currently Open -" & Chr(10) & Chr(10) & cFileList & Chr(10) & "The Workplan Will Not Update." & Chr(10) & Chr(10) & "Please Close All Open Files And Try Again.")
' Exit macro at this stage
' If no files open, process the rest of the macro
For lCount = 1 To .FoundFiles.Count 'Loop through all
'Open Workbook x and Set a Workbook variable to it
' Wrap the following code with File Open check once working above
' *********
Worksheets("Summary").Select
ActiveCell.SpecialCells(xlLastCell).Select
nLC = ActiveCell.Address
Range("A2", nLC).Select
Selection.Copy
Windows("Workplan.xls").Activate
' Don't do for first Workbook
If lCount <> 1 Then
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Activate
End If
ActiveSheet.Paste
wbResults.Close SaveChanges:=False
' *********
Next lCount
End If
End With
On Error GoTo 0
' add hyperlinks to column B data
nURLRow = 2
Range("B1").Select
ActiveCell.SpecialCells(xlLastCell).Select
' Selection.End(xlDown).Select
nLastRow = ActiveCell.Row
Do While nURLRow <= nLastRow
nWBname = Range("A" & nURLRow) & ".xls"
Range("B" & nURLRow).Select
nFNtext = ActiveCell.Value
nFNlink = "#'" & ActiveCell.Value & "'!A1"
ActiveCell.Formula = "=HYPERLINK(""" & nUNCpath & nWBname & nFNlink & """,""" & nFNtext & """)"
' Repeat Contact name in Column G
ActiveCell.Offset(0, 5).Activate
ActiveCell.Value = Range("A" & ActiveCell.Row).Value
nURLRow = nURLRow + 1
Loop
ActiveCell.Offset(1, -6).Activate
Application.ScreenUpdating = True
Sheet1.Protect Password:="******"
ActiveWorkbook.Save
Application.ScreenUpdating = False
End Sub