I've got a list of hyperlinks leading to multiple different hidden sheets in a workbook, using the following for each:
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Application.ScreenUpdating = False
Worksheets("LL - JLL").Visible = xlSheetVisible
Sheets("LL - JLL").Visible = True
Sheets("LL - JLL").Select
Application.ScreenUpdating = True
End Sub
From what I can tell this now applies to every hyperlink on the sheet. Eevery hyperlink now leads to the same sheet, LL - JLL, whereas I would need each hyperlink to lead to a different sheet. For example,
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Application.ScreenUpdating = False
Worksheets("LL - JLL").Visible = xlSheetVisible
Sheets("LL - JLL").Visible = True
Sheets("LL - JLL").Select
Application.ScreenUpdating = True
Application.ScreenUpdating = False
Worksheets("LL - EMS").Visible = xlSheetVisible
Sheets("LL - EMS").Visible = True
Sheets("LL - EMS").Select
Application.ScreenUpdating = True
Application.ScreenUpdating = False
Worksheets("LL- CCURE").Visible = xlSheetVisible
Sheets("LL- CCURE").Visible = True
Sheets("LL- CCURE").Select
Application.ScreenUpdating = True
End Sub
The following code makes all hyperlinks on the sheet lead to the LL-CURE sheet, rather than their correspondent sheets.
Creating a new Sub for different hyperlinks leads to
Compile error:
Ambiguous name detected: Worksheet_FolowHyperlink
Any guidance would be greatly appreciated :)
Logic:
Find the range which the hyperlink is pointing to
Find the name of the sheet to which the above range refers to
Pass the name to a common sub to unhide and activate the sheet
Code:
Is this what you are trying?
Option Explicit
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim rng As Range
'~~> Get the range the hyperlink is referrig to
Set rng = Application.Evaluate(Target.SubAddress)
'~~> Unhide and activate the sheet
UnHideAndActivate rng.Parent.Name
End Sub
Private Sub UnHideAndActivate(shName As String)
Dim scrnUpdating As Boolean
Dim dsplyAlerts As Boolean
On Error GoTo Whoa
With Application
'~~> Get user's current setting
scrnUpdating = .ScreenUpdating
dsplyAlerts = .DisplayAlerts
'~~> Set it to necessary setting
.ScreenUpdating = False
.DisplayAlerts = False
End With
'~~> Unhide and activate the sheet
Worksheets(shName).Visible = xlSheetVisible
Worksheets(shName).Activate
LetsContinue:
With Application
'~~> Reset original settings
.ScreenUpdating = scrnUpdating
.DisplayAlerts = dsplyAlerts
End With
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
Related
Any chance of getting help combining the two below codes?
I'll try to educate myself on combining these things as I'm sure it's not that complicated, but for now I'd appreciate any assistance.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Application.CutCopyMode = False Then
Application.Calculate
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim UndoList As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
On Error GoTo ErrExit
UndoList = Application.CommandBars("Standard").Controls("&Undo").List(1)
If Left(UndoList, 5) = "Paste" Or UndoList = "Auto Fill" Then
MsgBox "Copy / paste is not permitted" & vbCr & _
"- Creator"
With Application
.Undo
.CutCopyMode = False
End With
Target.Select
End If
'The UperCase part______________________________________________
If Not (Application.Intersect(Target, Range("E8:OF57")) _
Is Nothing) Then
With Target
If Not .HasFormula Then
Application.EnableEvents = False
.Value = UCase(.Value)
Application.EnableEvents = True
End If
End With
End If
'_______________________________________________________________
ErrExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
I'm trying to make my workbook as easy to use as possible, and to avoid user mistakes that mess upp formulas and so forth.
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Dim MyPicture As Object
Dim MyTop As Double
Dim MyLeft As Double
Dim TopRightCell As Range
'-----------------------------------------------------------
'- top right cell
With ActiveWindow.VisibleRange
r = 1
c = .Columns.Count
Set TopRightCell = .Cells(r, c)
End With
'------------------------------------------------------------
'- position picture
Set MyPicture = ActiveSheet.Pictures(1)
MyLeft = TopRightCell.Left - MyPicture.Width - 200
With MyPicture
.Left = MyLeft
End With
End Sub
The line starting with Private Sub or Sub begins the macro, and the line End Sub is the end of the macro.
Of the two code blocks you've pasted, the top contains two macros (one Worksheet_SelectionChange and one Worksheet_Change), and the second block only contains a SelectionChange one.
Depending which of those you wish to merge, just cut-paste the code from the inside of one sub (i.e. not including the start and end lines Private Sub and End Sub) into another, to make an amalgamated sub containing both sets of code. You may wish to amalgamate all three, but I'd guess it's just the two SelectionChange subs you want to merge.
I've been messing around with VBA coding and Macro's for the last couple of hours and I've encountered a problem. I read somewhere that you could optimise your code in some ways and tried them out on my project. Since then, I haven't been able to run any worksheet_change events since.
The addition consisted of two separate subs that I could call on before my own code ran and after it finished. These two subs looked like this:
Public CalcState As Long
Public EventState As Boolean
Public PageBreakState As Boolean
Sub OptimizeCode_Begin()
Application.ScreenUpdating = False
EventState = Application.EnableEvents
Application.EnableEvents = False
CalcState = Application.Calculation
Application.Calculation = xlCalculationManual
PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False
End Sub
Sub OptimizeCode_End()
ActiveSheet.DisplayPageBreaks = PageBreakState
Application.Calculation = CalcState
Application.EnableEvents = EventState
Application.ScreenUpdating = True
End Sub
My own code looked like this:
Option Explicit
Private Sub Worksheet_change(byVal Target As Range)
Dim LastPopulatedRow As Long
Call OptimizeCode_Begin
LastPopulatedRow = Sheets("Sheet1").Range.("B" & Rows.Count).End(xlUp).Rows
Sheets.("Sheet2").Range("C4:C" & LastPopulatedRow0.FillDown
Call Sub OptimizeCode-End
End Sub
I've looked everywhere on the internet for a potential fix but nothing seems to work. Can anybody help me out with this issue?
A Worksheet Change Issue
I have removed the PageBreaks setting because it refers to a Worksheet while the others refer to the Application object.
If EnableEvents is false then this code will not run anyway so why capture the state of EnableEvents. Just turn it off and when done turn it on again. The same for the other settings.
BTW you are turning off EnableEvents to avoid an infinite loop.
Copy the following into the sheet module e.g. Sheet1. Maybe run turnOnSettings first. Afterward, it should work on its own.
Implement Error Handling and Simplify the 'Optimization'
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo clearError
Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets("Sheet1")
Dim dws As Worksheet: Set dws = ThisWorkbook.Worksheets("Sheet2")
Dim LastPopulatedRow As Long
LastPopulatedRow = sws.Range("B" & sws.Rows.Count).End(xlUp).Row
turnOffSettings
On Error GoTo SettingsError
dws.Range("C4:C" & LastPopulatedRow).FillDown
turnOnSettings
ProcExit:
Exit Sub
SettingsError:
MsgBox "Run-time error '" & Err.Number & "': " & Err.Description
Resume Next ' Continue with 'turnOnSettings'
clearError:
MsgBox "Run-time error '" & Err.Number & "': " & Err.Description
Resume ProcExit ' An error occurred before 'turnOffSettings'
End Sub
Sub turnOffSettings()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
End Sub
Sub turnOnSettings()
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I get the run time error when I open the workbook. The open function works great without the close function, but as soon as I add the close function I get the error. Any suggestions?
Private Sub Workbook_Open()
Application.ScreenUpdating = False
For Each cell In Range("A1:Z1")
If cell.Value = "X" Then
cell.EntireColumn.Hidden = True
Else
cell.EntireColumn.Hidden = False
End If
Next cell
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Protect "1962"
Next ws
ThisWorkbook.Protect "1962", True
ThisWorkbook.Save
End Sub
The error occurs because you protect the worksheet in the BeforeClose routine. Hence the Workbook_Open doesn't have access to update it the next time it is being opened. Try this:
Private Sub Workbook_Open()
Dim cell As Range
Application.ScreenUpdating = False
ActiveSheet.Unprotect "1962" '<<<<
For Each cell In Range("A1:Z1")
If cell.Value = "X" Then
cell.EntireColumn.Hidden = True
Else
cell.EntireColumn.Hidden = False
End If
Next cell
ActiveSheet.Protect "1962" '<<<<
End Sub
i need some help to make my code work. My code is pretty simple. It goes through all my worksheets and make simple check in Columns A:D. If one cell has some text it will be locked. All free cells will stay for users unlocked.
It starts with other macros from my worksheet with Workbook_Open as Call command.
I used it all the time in each Worksheet separatly, but it won't work with new sheets so i decided to make it somehow global and dynamic for old sheets and new added sheets.
Old code:
Public Sub auo_open()
Dim strPassword As String
strPassword = "Athens"
With Tabelle1
.Unprotect Password:=strPassword
.Cells.Locked = True
On Error Resume Next
.Range("A:D").SpecialCells(xlCellTypeBlanks).Locked = False
On Error GoTo 0
.Protect Password:=strPassword, UserInterfaceOnly:=True, AllowFormattingCells:=True, AllowInsertingRows:=True
End With
Exit Sub
As you see it wasn't that good i had to put for each sheet a call command
new Code:
Public Sub Protection()
Dim ws As Worksheet
Dim strPassword As String
strPassword = "Athens"
For Each ws In ThisWorkbook.Worksheets
ws.Unprotect Password:=strPassword
ws.Cells.Locked = True
On Error Resume Next
ws.Range("A:D").SpecialCells(xlCellTypeBlanks).Locked = False
On Error GoTo 0
ws.Protect Password:=strPassword, UserInterfaceOnly:=True, AllowFormattingCells:=True, AllowInsertingRows:=True
Next ws
End Sub
Further to my comment above, try something like this. This code will automatically be applicable to the newly added worksheets
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim strPassword As String: strPassword = "Athens"
On Error GoTo Whoa
Application.EnableEvents = False
If Not Intersect(Target, Columns("A:D")) Is Nothing Then
With Sh
.Unprotect strPassword
Cells.Locked = True
Range("A:D").SpecialCells(xlCellTypeBlanks).Locked = False
.Protect strPassword
End With
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Screenshots
Put the code in the ThisWorkbook code area.
I have a spreadsheet that is edited by multiple users. To prevent tampering with previous data the cells are locked once data has been entered and the file saved. I have a few small bugs in the code though:
Even if the user has saved manually and then exits the application they are still prompted to save again.
The cells should be locked after a save when the application is running and not just when it is exited. Previously I had this code in the before_save event but the cells were being locked even if a save_as event was cancelled so I removed the code for now. Fixed
(Edit: I've just realised how obvious this error was. I even said it in this statement! Trying to lock cells after a save event using a before save event sub! )
Code
With ActiveSheet
.Unprotect Password:="oVc0obr02WpXeZGy"
.Cells.Locked = False
For Each Cell In ActiveSheet.UsedRange
If Cell.Value = "" Then
Cell.Locked = False
Else
Cell.Locked = True
End If
Next Cell
.Protect Password:="oVc0obr02WpXeZGy"
End With
The workbook open, hide all sheets and show all sheets subs are used to force the end user into enabling macros. Here is the full code:
Option Explicit
Const WelcomePage = "Macros"
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet
Dim wsActive As Worksheet
Dim vFilename As Variant
Dim bSaved As Boolean
'Turn off screen updating
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Record active worksheet
Set wsActive = ActiveSheet
'Prompt for Save As
If SaveAsUI = True Then
vFilename = Application.GetSaveAsFilename("", fileFilter:="Excel Files (*.xls), *.xls")
If CStr(vFilename) = "False" Then
bSaved = False
Else
'Save the workbook using the supplied filename
Call HideAllSheets
ThisWorkbook.SaveAs vFilename
Application.RecentFiles.Add vFilename
Call ShowAllSheets
bSaved = True
End If
Else
'Save the workbook
Call HideAllSheets
ThisWorkbook.Save
Call ShowAllSheets
bSaved = True
End If
'Restore file to where user was
wsActive.Activate
'Restore screen updates
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'Set application states appropriately
If bSaved Then
ThisWorkbook.Saved = True
Cancel = True
Else
Cancel = True
End If
End Sub
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Call ShowAllSheets
Application.ScreenUpdating = True
ThisWorkbook.Saved = True
End Sub
Private Sub HideAllSheets()
Dim ws As Worksheet
Worksheets(WelcomePage).Visible = xlSheetVisible
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVeryHidden
Next ws
Worksheets(WelcomePage).Activate
End Sub
Private Sub ShowAllSheets()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVisible
Next ws
Worksheets(WelcomePage).Visible = xlSheetVeryHidden
End Sub
'Lock Cells upon exit save if data has been entered
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim Cell As Range
With ActiveSheet
.Unprotect Password:="oVc0obr02WpXeZGy"
.Cells.Locked = False
For Each Cell In ActiveSheet.UsedRange
If Cell.Value = "" Then
Cell.Locked = False
Else
Cell.Locked = True
End If
Next Cell
.Protect Password:="oVc0obr02WpXeZGy"
End With
End Sub
Thanks :)
It is asking for them to save before exiting even though they have already saved because of these lines:
'Save the workbook
Call HideAllSheets
ThisWorkbook.Save
Call ShowAllSheets
bSaved = True
You are changing the worksheet after saving it (by calling ShowAllSheets) so it does need to be saved again. The same is true of the saveAs code.
I fixed the second problem by using another IF. This ensures the cells are only locked if the data is saved:
'Lock Cells before save if data has been entered
Dim rpcell As Range
With ActiveSheet
If bSaved = True Then
.Unprotect Password:="oVc0obr02WpXeZGy"
.Cells.Locked = False
For Each rpcell In ActiveSheet.UsedRange
If rpcell.Value = "" Then
rpcell.Locked = False
Else
rpcell.Locked = True
End If
Next rpcell
.Protect Password:="oVc0obr02WpXeZGy"
Else
MsgBox "The LogBook was not saved. You are free to edit the RP Log again", vbOKOnly, "LogBook Not Saved"
End If
End With