Thanks to these instructions
How do I assign a Macro to a checkbox dynamically using VBA
https://social.msdn.microsoft.com/Forums/office/en-US/877f15da-bbe4-4026-8ef2-8df77e1022f7/how-do-i-assign-a-macro-to-a-checkbox-dynamically-using-vba?forum=exceldev
I came up with an idea to:
Put checkboxes where I want on the sheet, e.g. in columns to the right from table with data for processing
Connect their (un)checking with logical variables which are used whether to start or not to start some procedures.
Wait for user to make his choices and check certain checkbox (e.g. the last in the list) to start selected procedures
Remove all (!) checkboxes and start the procedures selected shortly before.
This way the macros containing optional procedures are portable, as they don't DEPEND on the opened files but only WORK on them.
The files themselves remain unchanged by these free from control buttons coded in the macro (i.e. the sheet with checkboxes returns to it's previous state).
The following macro makes its own checkboxes (in column H), waits for user to choose options, memorizes choices, deletes all checkboxes, runs other procedures... and ends up without leaving a trace of itself in a workbook.
Dim FirstOptionLogical, SecondOptionLogical, ThirdOptionLogical As Boolean
' Making new checkboxes
Sub CheckBOxAdding()
Dim i As Long, id As Long
Dim cel As Range
Dim cbx As CheckBox
On Error GoTo CheckBoxAddingERROR
'FirstOptionLogical = False
'SecondOptionLogical = False
'ThirdOptionLogical = False
' Deleting all checkboxes, if any found
' Preventing error stops if there is no checkbox
On Error Resume Next
' Repeating with all checkboxes on active sheet
For Each chkbx In ActiveSheet.CheckBoxes
' Removing a checkbox
chkbx.Delete
' Next checkbox
Next
Range("G3").Select
ActiveSheet.Range(Columns("G:G"), Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlToLeft
On Error GoTo 0
Set cel = ActiveSheet.Cells(3, 8)
With cel
Set cbx = ActiveSheet.CheckBoxes.Add(.Left, .Top, 90, 3)
' height will autosize larger to the font
End With
cbx.Name = "Option_1"
cbx.Caption = "First Attribute changes, name it"
cbx.Display3DShading = True
' with a linked can trap sheet change event or link to other formulas
cbx.LinkedCell = cel.Offset(0, -1).Address
cbx.OnAction = "'" & ThisWorkbook.Name & "'!CheckBoxHandling"
''''''''''
Set cel = ActiveSheet.Cells(5, 8)
With cel
Set cbx = ActiveSheet.CheckBoxes.Add(.Left, .Top, 90, 3)
' height will autosize larger to the font
End With
cbx.Name = "Option_2"
cbx.Caption = "Second Attribute changes, name it"
cbx.Display3DShading = True
' with a linked can trap sheet change event or link to other formulas
cbx.LinkedCell = cel.Offset(0, -1).Address
cbx.OnAction = "'" & ThisWorkbook.Name & "'!CheckBoxHandling"
Set cel = ActiveSheet.Cells(7, 8)
With cel
Set cbx = ActiveSheet.CheckBoxes.Add(.Left, .Top, 90, 3)
' height will autosize larger to the font
End With
cbx.Name = "Option_3"
cbx.Caption = "Third Attribute changes, name it"
cbx.Display3DShading = True
' with a linked can trap sheet change event or link to other formulas
cbx.LinkedCell = cel.Offset(0, -1).Address
cbx.OnAction = "'" & ThisWorkbook.Name & "'!CheckBoxHandling"
Set cel = ActiveSheet.Cells(9, 8)
With cel
Set cbx = ActiveSheet.CheckBoxes.Add(.Left, .Top, 90, 3)
' .Font.Size = 36
' height will autosize larger to the font
End With
cbx.Name = "Option_4"
cbx.Caption = "START THE MACRO"
cbx.Display3DShading = True
' with a linked can trap sheet change event or link to other formulas
cbx.LinkedCell = cel.Offset(0, -1).Address
cbx.OnAction = "'" & ThisWorkbook.Name & "'!CheckBoxHandling"
Exit Sub
CheckBoxAddingERROR:
MsgBox "Something went wrong... ;-) in the sub CheckBOxAdding", vbCritical + vbOKOnly
End
End Sub
Sub CheckBoxHandling()
Dim sCaller, UsersChoice As String
Dim id As Long
Dim cbx As CheckBox
Dim shp As Shape
UsersChoice = ""
On Error GoTo CheckBoxHandlingERROR
sCaller = Application.Caller
Set shp = ActiveSheet.Shapes(sCaller)
Set cbx = ActiveSheet.CheckBoxes(sCaller)
id = Val(Mid$(sCaller, Len("Option_") + 1, 5))
' maybe something based on Select Case?
Select Case id
Case 1:
'MsgBox "You clicked the checkbox with option" & vbCrLf & "'Larger description of First Attribute changes, name it'"
FirstOptionLogical = Not FirstOptionLogical
'FirstOptionLogical = IIf(cbx.Value = xlOn, True, False)
'MsgBox "FirstOptionLogical = " & FirstOptionLogical & vbCrLf & "SecondOptionLogical = " & SecondOptionLogical & vbCrLf & "ThirdOptionLogical= " & ThirdOptionLogical
Case 2:
'MsgBox "You clicked the checkbox with option" & vbCrLf & "'Larger description of Second Attribute changes, name it'"
SecondOptionLogical = Not SecondOptionLogical
'SecondOptionLogical = IIf(cbx.Value = xlOn, True, False)
'MsgBox "FirstOptionLogical = " & FirstOptionLogical & vbCrLf & "SecondOptionLogical = " & SecondOptionLogical & vbCrLf & "ThirdOptionLogical= " & ThirdOptionLogical
Case 3:
'MsgBox "You clicked the checkbox with option" & vbCrLf & "'Larger description of Third Attribute changes, name it'"
ThirdOptionLogical = Not ThirdOptionLogical
'ThirdOptionLogical = IIf(cbx.Value = xlOn, True, False)
'MsgBox "FirstOptionLogical = " & FirstOptionLogical & vbCrLf & "SecondOptionLogical = " & SecondOptionLogical & vbCrLf & "ThirdOptionLogical= " & ThirdOptionLogical
Case 4:
If FirstOptionLogical Then
UsersChoice = UsersChoice & "- Larger description of First Attribute changes, name it " & vbCrLf
End If
If SecondOptionLogical Then
UsersChoice = UsersChoice & "- Larger description of Second Attribute changes, name it " & vbCrLf
End If
If ThirdOptionLogical Then
UsersChoice = UsersChoice & "- Larger description of Third Attribute changes, name it " & vbCrLf
End If
Ans0 = MsgBox("The following options were chosen:" & vbCrLf & UsersChoice & vbCrLf & vbCrLf & _
"You chose a checkbox with an option" & vbCrLf & "'START THE MACRO'" & vbCrLf & vbCrLf & " S H O U L D W E S T A R T T H E M A C R O ? ", vbYesNo + vbDefaultButton2 + vbQuestion)
If Ans0 = vbYes Then
'MACRO WITH PARAMETERS WE CHOSE BY CLICKING GETS STARTED...
' Delete all remaining checkboxes, if any (removing traces of the macro)
' In case of error, resume
On Error Resume Next
For Each chkbx In ActiveSheet.CheckBoxes
chkbx.Delete
Next
' Deleting all columns from G to the right
Range("G3").Select
ActiveWorkbook.Sheets(1).Range(Columns("G:G"), Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlToLeft
' Resetting on Error event to default
On Error GoTo 0
' If chosen, start sub 'Larger description of First Attribute changes, name it'
If FirstOptionLogical Then Call RunFirstOptionSub ' Name of the Sub
' If chosen, start sub 'Larger description of Second Attribute changes, name it'
If SecondOptionLogical Then Call RunSecondOptionSub ' Name of the Sub
' If chosen, start sub 'Larger description of Third Second Attribute changes, name it'
If ThirdOptionLogical Then Call RunThirdOptionSub ' Name of the Sub
Else
If Ans0 = vbNo Then
End If
End If
Exit Sub
End Select
cbx.TopLeftCell.Offset(, 2).Interior.Color = IIf(cbx.Value = xlOn, vbGreen, vbRed)
'MsgBox cbx.Caption & vbCr & IIf(cbx.Value = xlOn, " is ", " is not ") & "chosen"
Exit Sub
CheckBoxHandlingERROR:
MsgBox "Something went wrong... ;-) in the Sub CheckBoxHandling", vbCritical + vbOKOnly
End Sub
Sub RunFirstOptionSub()
' CODE
End Sub
Sub RunSecondOptionSub()
' CODE
End Sub
Sub RunThirdOptionSub()
' CODE
End Sub
Sub MacroWithOptionsEndsWithoutATrace()
FirstOptionLogical = False
SecondOptionLogical = False
ThirdOptionLogical = False
' OPTIONAL: Delete all remaining checkboxes, if any (most important when testing macro)
On Error Resume Next
For Each chkbx In ActiveSheet.CheckBoxes
chkbx.Delete
Next
' Resetting on Error event to default
On Error GoTo 0
CheckBOxAdding
End Sub
Share and use as you wish, as I used other's knowledge and experience.
I am very sorry, but I haven't found any other solution to present this to you, and I also haven't found anyone else presenting something similar to this.
Updated on Dec 17th 2019:
You could also use these checkboxes even easier way: write a macro that
creates a blank worksheet somewhere After:=Sheets(Sheets.Count) , so that it now becomes the new "last sheet",
put there these checkboxes,
check/uncheck them and start the macro by clicking the lowest one of them,
delete this last worksheet, leaving no traces of macro
That way you won't have to think again about where to put temporary checkboxes...
Updated on Oct 7th 2020:
I finally assumed, it would be better to make this an answered question, since it is.
Related
I have written the below code in excel vba to log changes made in sheets to the change log sheet. I want to disable that sub if a check box is checked.
This code works perfectly for what I need it to do, just need to figure out a sub that does not allow this to run if a box is checked so every change is not being logged when necessary.
'declare global variable
Dim oldValue As String
Dim oldAddress As String
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'declare variables for individual sheets
Dim sheet1 As String
NSWCCDFY22M = "Sheet 1"
Dim sheet2 As String
NSWCCDFY23M = "Sheet 2"
Dim sheet3As String
NSWCCDLSW = "Sheet 3"
'Logs change for any sheet that isnt the log itself (address, values, user, date/time, hyperlink, note)
If ActiveSheet.Name <> "ChangeLog" Then
Application.EnableEvents = False
Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = ActiveSheet.Name & " – " & Target.Address(0, 0)
Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = oldValue
Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 2).Value = Target.Value
Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 3).Value = Environ("username")
Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 4).Value = Now
'hyperlink to specific sheet
If ActiveSheet.Name = Sheet 1 Then
Sheets("ChangeLog").Hyperlinks.Add Anchor:=Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 5), Address:="", SubAddress:="'" & Sheet 1 & "'!" & oldAddress, TextToDisplay:=oldAddress
ElseIf ActiveSheet.Name = Sheet 2 Then
Sheets("ChangeLog").Hyperlinks.Add Anchor:=Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 5), Address:="", SubAddress:="'" & Sheet 2 & "'!" & oldAddress, TextToDisplay:=oldAddress
ElseIf ActiveSheet.Name = Sheet 3 Then
Sheets("ChangeLog").Hyperlinks.Add Anchor:=Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 5), Address:="", SubAddress:="'" & Sheet 3 & "'!" & oldAddress, TextToDisplay:=oldAddress
End If
'input box for note
Dim commentChange As String
commentChange = InputBox("Please enter a note for this change.", "Logging")
Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 6).Value = commentChange
'if input box is not filled in
If LenB(commentChange) = 0 Then
MsgBox "You must enter a note for the change you've just made." & vbCrLf & " " & vbCrLf & "You will be taken to the Change Log to add a note and can navigate back to this sheet using the link associated with your change.", vbExclamation, "Change Log Required Actions"
Sheets("ChangeLog").Select
'go to log if a note is not put in
Dim lRow As Long
Dim lColumn As Long
lRow = Range("A1").End(xlDown).Row
lColumn = Range("A1").End(xlToRight).Column
Cells(lRow, lColumn).Select
Dim OutPut As Integer
'infobox when taken to log
OutPut = MsgBox("1. Please enter a note for the change you've just made." & vbCrLf & " " & vbCrLf & "2. Click the link in the 'Link' Column to return to the previous sheet where the change was made.", vbInformation, "Change Log Required Actions")
End If
Sheets("ChangeLog").Columns("A:G").AutoFit
Application.EnableEvents = True
End If
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Count = 1 Then
oldValue = Target.Value
End If
oldAddress = Target.Address
End Sub
I keep getting this error for some code I am adapting. I have used this in other workbooks without issue as shown. The line "Me.Controls("Reg" & X).Value = findvalue" is where I am getting stuck. I use this throughout my project again without issue in other projects. Any ideas?
Private Sub lstLookup_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'Search new and existing training and return data to user controls at the bottom of the form
'declare the variables
Dim ID As String
Dim I As Integer
Dim findvalue
'error block
On Error GoTo errHandler:
'get the select value from the listbox
For I = 0 To lstLookup.ListCount - 1
If lstLookup.Selected(I) = True Then
'set the listbox column
ID = lstLookup.List(I, 8)
End If
Next I
'find the value in the range
Set findvalue = Sheet2.Range("J:J").Find(What:=ID, LookIn:=xlValues).Offset(0, -8)
'add the values to the userform controls
cNum = 9
For X = 1 To cNum
**Me.Controls("Reg" & X).Value = findvalue**
Set findvalue = findvalue.Offset(0, 1)
Next
'disable controls force user to select option
'error block
On Error GoTo 0
Exit Sub
errHandler::
MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " _
& Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Please notify the administrator"
End Sub
For my code, I am trying to find the difference between an objects value from two different days.
Sub GoingBack()
numberCube = InputBox("Which file are we going back to?")
numberYest = numberCube - 1
Workbooks.Open ("C:\Users\user\Downloads\file (" & numberCube & ").xlsx")
Workbooks.Open ("C:\Users\user\Downloads\file (" & numberYest & ").xlsx")
Set Work1 = Workbooks("file (" & numberCube & ").xlsx")
Set Work2 = Workbooks("file (" & numberCube - 1 & ").xlsx")
'Add the Time Difference Column (AA--27)
LastRow67 = Work1.Sheets("67").Cells(Rows.Count, 2).End(xlUp).Row
Work1.Sheets("67").Cells(1, 27).Value = "Time Clock Difference"
Work1.Sheets("67").Cells(1, 27).FormulaR1C1 = "=RC[-15]-VLOOKUP(RC[-21], '[file (" & numberYest & ").xlsx]67'!$F:$L, 7, FALSE)"
Work1.Sheets("67").Range("AA2").Select
Selection.AutoFill Destination:=Range("AA2:AA" & LastRow67)
Work1.Close savechanges:=True
Work2.Close savechanges:=True
End Sub
The line that is throwing the "Application Defined or Object Defined" error is:
Work1.Sheets("67").Cells(1, 27).FormulaR1C1 = "=RC[-15]-VLOOKUP(RC[-21], '[file (" & numberYest & ").xlsx]67'!$F:$L, 7, FALSE)"
I have tried using Range.Formula, and that threw the error as well.
Work1.Sheets("67").Range("AA2").Formula = "=L2-VLOOKUP(F2, '[file (" & numberYest & ").xlsx]67'!$F:$L, 7, FALSE)"
Any help would be appreciated. Thank you so much.
EDIT: I typed in the formula in Excel, and it works. I recorded the inputting of the formula, and the below is the result. I clicked/referenced columns F through L, so I'm not sure why it is only displaying C6:C12 below.
ActiveCell.FormulaR1C1 = "=RC[-15]-VLOOKUP(RC[-21],'[file.xlsx]67'!C6:C12,7,FALSE)"
Just because you've always done something a certain way, doesn't make it good practice. There are a lot of opportunities for improvement here.
Consider this refactor:
Option Explicit ' always!
Sub GoingBack()
' Dim all variables
Dim numberCube As Variant
Dim numberYest As Long
Dim Work1 As Workbook
Dim Work2 As Workbook
Dim LastRow67 As Long
Dim WorkSh1 As Worksheet
Dim WorkSh2 As Worksheet
Dim Pth As String
' avoid repeats of the same data
Pth = "C:\Users\user\Downloads\"
' Might be better to use FileDialog, but anyway...
' Handle user cancel and invalid entry
Do
numberCube = InputBox("Which file are we going back to?")
If numberCube = vbNullString Then
' User canceled, exit
Exit Sub
End If
If IsNumeric(numberCube) Then Exit Do
MsgBox "Enter a Number", vbCritical + vbOKOnly, "Error"
Loop
numberYest = numberCube - 1
' Handle files missing or won't open
On Error Resume Next
Set Work1 = Workbooks.Open(Pth & "file (" & numberCube & ").xlsx")
On Error GoTo 0
If Work1 Is Nothing Then
'Work1 failed to open, what now?
GoTo CleanUp
End If
On Error Resume Next
Set Work2 = Workbooks.Open(Pth & "file (" & numberYest & ").xlsx")
On Error GoTo 0
If Work2 Is Nothing Then
'Work2 failed to open, what now?
GoTo CleanUp
End If
' Set refences to worksheets and handle if missing
On Error Resume Next
Set WorkSh1 = Work1.Sheets("67")
On Error GoTo 0
If WorkSh1 Is Nothing Then
' WorkSh1 doesn't exist, what now?
GoTo CleanUp
End If
On Error Resume Next
Set WorkSh2 = Work2.Sheets("67")
On Error GoTo 0
If WorkSh2 Is Nothing Then
' WorkSh2 doesn't exist, what now?
GoTo CleanUp
End If
'Add the Time Difference Column (AA--27)
' use your references
With WorkSh1
LastRow67 = .Cells(.Rows.Count, 2).End(xlUp).Row
.Cells(1, 27).value = "Time Clock Difference"
' no need for select or Autofill
' Can't use A1 style in FormulaR1C1
.Range(.Cells(1, 27), .Cells(LastRow67, 27)).FormulaR1C1 = _
"=RC[-15]-VLOOKUP(RC[-21], " & WorkSh2.Range("F:L").Address(, , xlR1C1, True) & ", 7, FALSE)"
End With
CleanUp:
Work1.Close SaveChanges:=True
Work2.Close SaveChanges:=False ' you didn't change file 2
End Sub
Edit:
After doing a bit more research I stumbled on this handy little shortcut:
Just right click on the little arrows on the bottom left corner to show all sheets - no code required!
I have an excel workbook with 100 tabs. Luckily for me the tabs are all numbered 1-100. I Have an index page with all the numbers in a row and I would like to make a row next to that row with a hyperlink to the numbered tab.
A B
---------------------------
| 1 | link to tab 1 |
---------------------------
| 2 | link to tab 2 |
---------------------------
etc...
So far the most promising thing I've found is:
=Hyperlink(“C:\Documents and Settings\Admin1\Desktop\” & A1 & “.xls”,A1)
I know that the hyperlink function expects:
=HYPERLINK(link_location,friendly_name)
And when I do it manually, I get this:
=HYPERLINK('1'!$A$1,A1)
So I want to do something like this:
=HYPERLINK('& A1 &'!$A$1,A1)
But it's not working. Any help is much appreciated. Also, if there is an easier way to approach this - I am all ears.
With code something like this
Press Alt + F11 to open the Visual Basic Editor (VBE).
From the Menu, choose Insert-Module.
Paste the code into the right-hand code window.
Close the VBE, save the file if desired.
In excel-2003 go to Tools-Macro-Macros and double-click CreateTOC
In excel-2007 click the Macros button in the Code group of the Developer tab, then click CreateTOC in the list box.
Option Explicit
Sub CreateTOC()
Dim ws As Worksheet
Dim nmToc As Name
Dim rng1 As Range
Dim lngProceed As Boolean
Dim bNonWkSht As Boolean
Dim lngSht As Long
Dim lngShtNum As Long
Dim strWScode As String
Dim vbCodeMod
'Test for an ActiveWorkbook to summarise
If ActiveWorkbook Is Nothing Then
MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
Exit Sub
End If
'Turn off updates, alerts and events
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
'If the Table of Contents exists (using a marker range name "TOC_Index") prompt the user whether to proceed
On Error Resume Next
Set nmToc = ActiveWorkbook.Names("TOC_Index")
If Not nmToc Is Nothing Then
lngProceed = MsgBox("Index exists!" & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbCritical, "Warning")
If lngProceed = vbYes Then
Exit Sub
Else
ActiveWorkbook.Sheets(Range("TOC_Index").Parent.Name).Delete
End If
End If
Set ws = ActiveWorkbook.Sheets.Add
ws.Move before:=Sheets(1)
'Add the marker range name
ActiveWorkbook.Names.Add "TOC_INDEX", ws.[a1]
ws.Name = "TOC_Index"
On Error GoTo 0
On Error GoTo ErrHandler
For lngSht = 2 To ActiveWorkbook.Sheets.Count
'set to start at A6 of TOC sheet
'Test sheets to determine whether they are normal worksheets
ws.Cells(lngSht + 4, 2).Value = TypeName(ActiveWorkbook.Sheets(lngSht))
If TypeName(ActiveWorkbook.Sheets(lngSht)) = "Worksheet" Then
'Add hyperlinks to normal worksheets
ws.Hyperlinks.Add Anchor:=ws.Cells(lngSht + 4, 1), Address:="", SubAddress:="'" & ActiveWorkbook.Sheets(lngSht).Name & "'!A1", TextToDisplay:=ActiveWorkbook.Sheets(lngSht).Name
Else
'Add name of any non-worksheets
ws.Cells(lngSht + 4, 1).Value = ActiveWorkbook.Sheets(lngSht).Name
'Colour these sheets yellow
ws.Cells(lngSht + 4, 1).Interior.Color = vbYellow
ws.Cells(lngSht + 4, 2).Font.Italic = True
bNonWkSht = True
End If
Next lngSht
'Add headers and formatting
With ws
With .[a1:a4]
.Value = Application.Transpose(Array(ActiveWorkbook.Name, "", Format(Now(), "dd-mmm-yy hh:mm"), ActiveWorkbook.Sheets.Count - 1 & " sheets"))
.Font.Size = 14
.Cells(1).Font.Bold = True
End With
With .[a6].Resize(lngSht - 1, 1)
.Font.Bold = True
.Font.ColorIndex = 41
.Resize(1, 2).EntireColumn.HorizontalAlignment = xlLeft
.Columns("A:B").EntireColumn.AutoFit
End With
End With
'Add warnings and macro code if there are non WorkSheet types present
If bNonWkSht Then
With ws.[A5]
.Value = "This workbook contains at least one Chart or Dialog Sheet. These sheets will only be activated if macros are enabled (NB: Please doubleclick yellow sheet names to select them)"
.Font.ColorIndex = 3
.Font.Italic = True
End With
strWScode = "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)" & vbCrLf _
& " Dim rng1 As Range" & vbCrLf _
& " Set rng1 = Intersect(Target, Range([a6], Cells(Rows.Count, 1).End(xlUp)))" & vbCrLf _
& " If rng1 Is Nothing Then Exit Sub" & vbCrLf _
& " On Error Resume Next" & vbCrLf _
& " If Target.Cells(1).Offset(0, 1) <> ""Worksheet"" Then Sheets(Target.Value).Activate" & vbCrLf _
& " If Err.Number <> 0 Then MsgBox ""Could not select sheet"" & Target.Value" & vbCrLf _
& "End Sub" & vbCrLf
Set vbCodeMod = ActiveWorkbook.VBProject.VBComponents(ws.CodeName)
vbCodeMod.CodeModule.AddFromString strWScode
End If
'tidy up Application settins
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
ErrHandler:
If Err.Number <> 0 Then MsgBox Err.Description & vbCrLf & "Please note that your Application settings have been reset", vbCritical, "Code Error!"
End Sub
My snippet:
Sub AddLinks()
Dim wksLinks As Worksheet
Dim wks As Worksheet
Dim row As Integer
Set wksLinks = Worksheets("Links")
wksLinks.UsedRange.Delete
row = 1
For Each wks In Worksheets
' Debug.Print wks.Name
wks.Hyperlinks.Add wksLinks.Cells(row, 1), "", wks.Name & "!A1", , wks.Name
row = row + 1
Next wks
End Sub
Assumes a worksheet named 'Links"
Might not be a direct answer to your method, but I would create something more pleasing to the eye, like ... some shapes formatted nicely and then asign some basic macros to them, for selecting the sheets.
This can be easely modified to go to a specific address (like the Go TO Ctrl+Gbuilt in Excel feature).Hope this helps on the fashion style of your file :)
EDIT!
Don't know why my answer received a -1 rating. As I've said it's an alternative and not a direct solution to the given question. Still, I do believe my initial answer was superficial without a proven/working VBA code, thus I've developed a little practical example below:
Sub Add_Link_Buttons()
'Clear any Shapes present in the "Links" sheet
For j = ActiveSheet.Shapes().Count To 1 Step -1
ActiveSheet.Shapes(j).Delete
Next j
'Add the shapes and then asign the "Link" Macros
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveSheet.Shapes.AddShape Type:=msoShapeRoundedRectangle, Left:=50, Top:=i * 25, Width:=100, Height:=25
ActiveSheet.Shapes(i).OnAction = "Select_Sheet" & i
'even add the the sheet Name as Test:
ActiveSheet.Shapes(i).TextFrame2.TextRange.Characters.Text = Sheets(i).Name
Next i
End Sub
where the "basic Select Macros" whould be:
Sub Select_Sheet1()
ActiveWorkbook.Sheets(1).Select
End Sub
Sub Select_Sheet2()
ActiveWorkbook.Sheets(2).Select
End Sub
Sub Select_Sheet3()
ActiveWorkbook.Sheets(3).Select
End Sub
' and so on!
' Note! to link a specific address within the sheets use the range like in 'Sheets(1).Range("A1").Select
Again, This is an alternative and doesn't add hyperlinks (as asked), but enables the sheet select from the same location.
TO address the buttons to links for outside files, simply define the address > filename/workbook Sheets() and Open ;)
Here is the code I use:
Sub CreateIndex()
'This macro checks for an Index tab in the active worksheet and creates one if one does not already exist.
'If an Index tab already exists, the user is asked to continue. If they continue, the original Index tab is replaced by a new Index tab. If they do not continue, the macro stops.
'The user is then asked if they want to create a link back to the Index tab on all other worksheets (yes or no) and the macro acts accordingly.
Dim wsIndex As Worksheet
Dim wSheet As Worksheet
Dim retV As Integer
Dim i As Integer
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Set wsIndex = Worksheets.Add(Before:=Sheets(1))
With wsIndex
On Error Resume Next
.Name = "Index"
If Err.Number = 1004 Then
If MsgBox(Prompt:="A sheet named ""Index"" already exists. Do you wish to continue by replacing it with a new Index?", _
Buttons:=vbInformation + vbYesNo) = vbNo Then
.Delete
MsgBox "No changes were made."
GoTo EarlyExit:
End If
Sheets("Index").Delete
.Name = "Index"
End If
On Error GoTo 0
retV = MsgBox("Create links back to ""Index"" sheet on other sheets?", vbYesNo, "Linking Options")
For Each wSheet In ActiveWorkbook.Worksheets
If wSheet.Name <> "Index" Then
i = i + 1
If wSheet.Visible = xlSheetVisible Then
.Range("B" & i).Value = "Visible"
ElseIf wSheet.Visible = xlSheetHidden Then
.Range("B" & i).Value = "Hidden"
Else
.Range("B" & i).Value = "Very Hidden"
End If
.Hyperlinks.Add Anchor:=.Range("A" & i), Address:="", SubAddress:="'" & wSheet.Name & "'!A1", TextToDisplay:=wSheet.Name
If retV = 6 And wSheet.Range("A1").Value <> "Index" Then
wSheet.Rows(1).Insert
wSheet.Range("A1").Hyperlinks.Add Anchor:=wSheet.Range("A1"), Address:="", SubAddress:="'" & .Name & "'!A1", TextToDisplay:=.Name
End If
End If
Next wSheet
.Rows(1).Insert
With .Rows(1).Font
.Bold = True
.Underline = xlUnderlineStyleSingle
End With
.Range("A1") = "Sheet Name"
.Range("B1") = "Status"
.UsedRange.AutoFilter
Rows("2:2").Select
ActiveWindow.FreezePanes = True
Application.Goto Reference:="R1C1"
.Columns("A:B").AutoFit
End With
With ActiveWorkbook.Sheets("Index").Tab
.Color = 255
.TintAndShade = 0
End With
EarlyExit:
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
-Mike
We have a excel file with a bunch of sheets. The first sheet is a "Search page" thing... where we want to type the name of the spreadsheet (for example in cell A1) we are looking for and then that would automatically pop up the right spreadsheet (within the same file).
I tried that, it didn't work at all :
Function ActivateWB(wbname As String)
'Open wbname.
Workbooks(wbname).Activate
End Function
Two code sets below
Add a full hyperlinked Table of Contents page
For your specific question re finding a sheet that is referred to by A1 on the first sheet see 'JumpSheet' code (at bottom)
Create TOC
Option Explicit
Sub CreateTOC()
Dim ws As Worksheet
Dim nmToc As Name
Dim rng1 As Range
Dim lngProceed As Boolean
Dim bNonWkSht As Boolean
Dim lngSht As Long
Dim lngShtNum As Long
Dim strWScode As String
Dim vbCodeMod
'Test for an ActiveWorkbook to summarise
If ActiveWorkbook Is Nothing Then
MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
Exit Sub
End If
'Turn off updates, alerts and events
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
'If the Table of Contents exists (using a marker range name "TOC_Index") prompt the user whether to proceed
On Error Resume Next
Set nmToc = ActiveWorkbook.Names("TOC_Index")
If Not nmToc Is Nothing Then
lngProceed = MsgBox("Index exists!" & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbCritical, "Warning")
If lngProceed = vbYes Then
Exit Sub
Else
ActiveWorkbook.Sheets(Range("TOC_Index").Parent.Name).Delete
End If
End If
Set ws = ActiveWorkbook.Sheets.Add
ws.Move before:=Sheets(1)
'Add the marker range name
ActiveWorkbook.Names.Add "TOC_INDEX", ws.[a1]
ws.Name = "TOC_Index"
On Error GoTo 0
On Error GoTo ErrHandler
For lngSht = 2 To ActiveWorkbook.Sheets.Count
'set to start at A6 of TOC sheet
'Test sheets to determine whether they are normal worksheets
ws.Cells(lngSht + 4, 2).Value = TypeName(ActiveWorkbook.Sheets(lngSht))
If TypeName(ActiveWorkbook.Sheets(lngSht)) = "Worksheet" Then
'Add hyperlinks to normal worksheets
ws.Hyperlinks.Add Anchor:=ws.Cells(lngSht + 4, 1), Address:="", SubAddress:="'" & ActiveWorkbook.Sheets(lngSht).Name & "'!A1", TextToDisplay:=ActiveWorkbook.Sheets(lngSht).Name
Else
'Add name of any non-worksheets
ws.Cells(lngSht + 4, 1).Value = ActiveWorkbook.Sheets(lngSht).Name
'Colour these sheets yellow
ws.Cells(lngSht + 4, 1).Interior.Color = vbYellow
ws.Cells(lngSht + 4, 2).Font.Italic = True
bNonWkSht = True
End If
Next lngSht
'Add headers and formatting
With ws
With .[a1:a4]
.Value = Application.Transpose(Array(ActiveWorkbook.Name, "", Format(Now(), "dd-mmm-yy hh:mm"), ActiveWorkbook.Sheets.Count - 1 & " sheets"))
.Font.Size = 14
.Cells(1).Font.Bold = True
End With
With .[a6].Resize(lngSht - 1, 1)
.Font.Bold = True
.Font.ColorIndex = 41
.Resize(1, 2).EntireColumn.HorizontalAlignment = xlLeft
.Columns("A:B").EntireColumn.AutoFit
End With
End With
'Add warnings and macro code if there are non WorkSheet types present
If bNonWkSht Then
With ws.[A5]
.Value = "This workbook contains at least one Chart or Dialog Sheet. These sheets will only be activated if macros are enabled (NB: Please doubleclick yellow sheet names to select them)"
.Font.ColorIndex = 3
.Font.Italic = True
End With
strWScode = "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)" & vbCrLf _
& " Dim rng1 As Range" & vbCrLf _
& " Set rng1 = Intersect(Target, Range([a6], Cells(Rows.Count, 1).End(xlUp)))" & vbCrLf _
& " If rng1 Is Nothing Then Exit Sub" & vbCrLf _
& " On Error Resume Next" & vbCrLf _
& " If Target.Cells(1).Offset(0, 1) <> ""Worksheet"" Then Sheets(Target.Value).Activate" & vbCrLf _
& " If Err.Number <> 0 Then MsgBox ""Could not select sheet"" & Target.Value" & vbCrLf _
& "End Sub" & vbCrLf
Set vbCodeMod = ActiveWorkbook.VBProject.VBComponents(ws.CodeName)
vbCodeMod.CodeModule.AddFromString strWScode
End If
'tidy up Application settins
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
ErrHandler:
If Err.Number <> 0 Then MsgBox Err.Description & vbCrLf & "Please note that your Application settings have been reset", vbCritical, "Code Error!"
End Sub
Jump Sheet
Sub JumpSheet()
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(Sheets(1).[a1].Value)
On Error GoTo 0
If Not ws Is Nothing Then
Application.Goto ws.[a1]
Else
MsgBox "Sheet not found", vbCritical
End If
End Sub
Iterate over all sheets of the current workbook and activate the one with the right name. Here is some code which should give you the idea, You can put this in the code section of your search sheet and associate it with the "Clicked" event of a button.
Option Explicit
Sub Search_Click()
Dim sheetName As String, i As Long
sheetName = Range("A1")
For i = 1 To ThisWorkbook.Sheets.Count
If ThisWorkbook.Sheets(i).Name = sheetName Then
ThisWorkbook.Sheets(i).Activate
Exit For
End If
Next
End Sub
I am just confused about the question. Are you trying to open Workbook or Worksheet?.
If you trying to navigate to worksheet with in workbook,
E.g.
Worksheets("Sheet2").Activate