Sub Links()
' warning box
Dim Name As String
Name = ActiveSheet.Range("Q84")
Dim Resp As Integer
Resp = MsgBox("Click 'Yes' to automatically save this spreadsheet and set up links to the Summary. " & vbNewLine & _
"Your valuation spreadsheet will be saved to the following directory... " & vbNewLine & _
" " & vbNewLine & _
"E:\Summary\Costs\" & Name & vbNewLine & _
" " & vbNewLine & _
"If you are not connected to the Network please click 'No' and set up the links at a " & vbNewLine & _
"later date. " & vbNewLine & _
" " & vbNewLine & _
"Do you want to Continue? ", 36, "Auto Save and Summary Links")
If Resp = 6 Then
'On Error GoTo ErrorMessage
' setup String
Dim myfile As String
Dim openFile As String
Dim OrderNumber As String
OrderNumber = ActiveSheet.Range("A28")
' autosave
ActiveWorkbook.SaveAs FileName:=Range("A4"), FileFormat _
:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
' setup myFile
myfile = ActiveWorkbook.Path & "\" & "[" & ActiveWorkbook.Name & "]"
openFile = ActiveWorkbook.Name
'open summary and auto update links
Workbooks.Open FileName:= _
"E:\Summary\Costs\Summary.xls", UpdateLinks:=3
' insert links > unhide, copy cells, hide and rename using myFile
Dim sht As Object
For Each sht In ActiveWorkbook.Sheets
sht.Visible = xlSheetVisible
Next sht
ActiveWorkbook.Sheets("Info").Visible = xlSheetVeryHidden
' check to see whether project has already been added to summary
Sheets("SUMMARIES").Select
ActiveSheet.Unprotect ""
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Application.WorksheetFunction.CountIf(Sheets("SUMMARIES").Range("A6:A65536"), OrderNumber) > 0 Then GoTo RefExists Else
ActiveSheet.Protect ""
Sheets("SUMMARIES").Select
ActiveSheet.Unprotect ""
ActiveSheet.Calculate
Rows("7:7").Select
Selection.Insert Shift:=xlDown
Rows("5:7").Select
Range("A7").Activate
Selection.EntireRow.Hidden = False
Range("B6:BH6").Select
Selection.Copy
Range("B7").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Rows("6:6").Select
Range("B6").Activate
Selection.EntireRow.Hidden = True
Range("B7:BH7").Select
Dim Item As Range
Dim File_Strt As Long
Dim Old_File As String
Dim Strt
Dim item2
Dim Strt_Num As Long
Dim Op_Num As Long
Dim Actual_Old_File As String
Dim bang As Long
Strt = Array("=", "-", "+", "*", "/", "<", ">", "(", ",", "^", "&")
Actual_Old_File = ""
Old_File = "[template_cost_breakdown.xls]"
For Each Item In Selection
File_Strt = InStr(1, Item.Formula, Old_File, vbTextCompare)
If File_Strt > 0 Then
If Actual_Old_File = "" Then
Strt_Num = 0
For Each item2 In Strt
Op_Num = InStrRev(Item.Formula, item2, File_Strt)
If Op_Num > Strt_Num Then
Strt_Num = Op_Num
End If
Next
Actual_Old_File = Mid(Item.Formula, Strt_Num + 1, File_Strt - Strt_Num + Len(Old_File) - 1)
bang = InStr(1, Item.Formula, "!")
If Mid(Item.Formula, bang - 1, 1) = "'" And Left(myfile, 1) <> "'" Then
myfile = "'" & myfile
End If
End If
Item.Formula = Replace(Item.Formula, Actual_Old_File, myfile, , , vbTextCompare)
End If
Next Item
' save and close valuation summary workbook
ActiveWorkbook.Sheets("Info").Visible = xlSheetVisible
For Each sht In ActiveWorkbook.Sheets
If sht.Name <> "Info" Then sht.Visible = xlSheetVeryHidden
Next sht
ActiveWorkbook.Close SaveChanges:=True
Application.Workbooks(openFile).Activate
Sheets("Report").Select
Range("G25").Select
MsgBox "This Project has been successfully saved and added to the Summary. " & vbNewLine & _
" " & vbNewLine & _
"Click OK to Continue.", 0, "Summary Links"
End If
MacroExit:
Exit Sub
ErrorMessage:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "" _
& vbCrLf & "Please report the following information: " _
& vbCrLf & " " _
& vbCrLf & "Macro Name: Links" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MacroExit
RefExists:
ActiveSheet.Protect ""
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "The following Project has either already been added to the Summary " & vbNewLine & _
"" & vbNewLine & _
"Valuation Filename:" & vbNewLine & _
"" & openFile & " " & vbNewLine & _
"", 64, "Project Previously Added"
ActiveWorkbook.Close SaveChanges:=False
Application.Workbooks(openFile).Activate
MsgBox "This Project has been successfully saved. " & vbNewLine & _
" " & vbNewLine & _
"Click OK to Continue.", 0, "Auto Save Valuations"
End Sub
