I have tried a lot of stuff but I can't find a fix to it I made it so that a check box if checked, it makes true and false statements in cell Q46 and function =IF(Q46=TRUE,DAY(TODAY()),0 in cell Q47 and in VBA I used this code I know it has a lot of validation that i won't use but I found it online and it works perfectly fine
Private Sub Worksheet_Change(ByVal Target As Range)
'Specify the target cell whose entry shall be the sheet tab name.
If Target.Address <> "$Q$47" Then Exit Sub
'If the target cell is empty (contents cleared) then don't change the sheet name
If IsEmpty(Target) Then Exit Sub
'If the length of the target cell's entry is greater than 31 characters, disallow the entry.
If Len(Target.Value) > 31 Then
MsgBox "Worksheet tab names cannot be greater than 31 characters in length." & vbCrLf & _
"You entered " & Target.Value & ", which has " & Len(Target.Value) & " characters.", , "Keep it under 31 characters"
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
Exit Sub
End If
'Sheet tab names cannot contain the characters /, \, [, ], *, ?, or :.
'Verify that none of these characters are present in the cell's entry.
Dim IllegalCharacter(1 To 7) As String, i As Integer
IllegalCharacter(1) = "/"
IllegalCharacter(2) = "\"
IllegalCharacter(3) = "["
IllegalCharacter(4) = "]"
IllegalCharacter(5) = "*"
IllegalCharacter(6) = "?"
IllegalCharacter(7) = ":"
For i = 1 To 7
If InStr(Target.Value, (IllegalCharacter(i))) > 0 Then
MsgBox "You used a character that violates sheet naming rules." & vbCrLf & vbCrLf & _
"Please re-enter a sheet name without the ''" & IllegalCharacter(i) & "'' character.", 48, "Not a possible sheet name !!"
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
Exit Sub
End If
Next i
'Verify that the proposed sheet name does not already exist in the workbook.
Dim strSheetName As String, wks As Worksheet, bln As Boolean
strSheetName = Trim(Target.Value)
On Error Resume Next
Set wks = ActiveWorkbook.Worksheets(strSheetName)
On Error Resume Next
If Not wks Is Nothing Then
bln = True
Else
bln = False
Err.Clear
End If
'If the worksheet name does not already exist, name the active sheet as the target cell value.
'Otherwise, advise the user that duplicate sheet names are not allowed.
If bln = False Then
ActiveSheet.Name = strSheetName
Else
MsgBox "There is already a sheet named " & strSheetName & "." & vbCrLf & _
"Please enter a unique name for this sheet."
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
End If
End Sub
but the problem is the cell I use which is Q47 must be active, its like I must write in it the value for it to rename not check a box so is there a way I can make it so that when I check the box and it becomes "TRUE" in cell Q46 and write day in Q47 it automatically change the sheet name to Q47?
The checkbox with a linked cell will not trigger the worksheet_change event. Do assign a macro to the checkbox (right click ->view code).
As you said it there is a lot in that code that you don't need but as you want to keep it as did not take it out
Private Sub CheckBox1_Click()
Dim Target As Range
Set Target = ActiveSheet.Range("q47")
'Specify the target cell whose entry shall be the sheet tab name.
If Target.Address <> "$Q$47" Then
Exit Sub
End If
'If the target cell is empty (contents cleared) then don't change the sheet name
If IsEmpty(Target) Then Exit Sub
'If the length of the target cell's entry is greater than 31 characters, disallow the entry.
If Len(Target.Value) > 31 Then
MsgBox "Worksheet tab names cannot be greater than 31 characters in length." & vbCrLf & _
"You entered " & Target.Value & ", which has " & Len(Target.Value) & " characters.", , "Keep it under 31 characters"
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
Exit Sub
End If
'Sheet tab names cannot contain the characters /, \, [, ], *, ?, or :.
'Verify that none of these characters are present in the cell's entry.
Dim IllegalCharacter(1 To 7) As String, i As Integer
IllegalCharacter(1) = "/"
IllegalCharacter(2) = "\"
IllegalCharacter(3) = "["
IllegalCharacter(4) = "]"
IllegalCharacter(5) = "*"
IllegalCharacter(6) = "?"
IllegalCharacter(7) = ":"
For i = 1 To 7
If InStr(Target.Value, (IllegalCharacter(i))) > 0 Then
MsgBox "You used a character that violates sheet naming rules." & vbCrLf & vbCrLf & _
"Please re-enter a sheet name without the ''" & IllegalCharacter(i) & "'' character.", 48, "Not a possible sheet name !!"
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
Exit Sub
End If
Next i
'Verify that the proposed sheet name does not already exist in the workbook.
Dim strSheetName As String, wks As Worksheet, bln As Boolean
strSheetName = Trim(Target.Value)
On Error Resume Next
Set wks = ActiveWorkbook.Worksheets(strSheetName)
On Error Resume Next
If Not wks Is Nothing Then
bln = True
Else
bln = False
Err.Clear
End If
'If the worksheet name does not already exist, name the active sheet as the target cell value.
'Otherwise, advise the user that duplicate sheet names are not allowed.
If bln = False Then
ActiveSheet.Name = strSheetName
Else
MsgBox "There is already a sheet named " & strSheetName & "." & vbCrLf & _
"Please enter a unique name for this sheet."
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
End If
End Sub
Related
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.
I try to change the worksheet tab name based excel cell value but when i try to run the code its asking create a macro please help
I created one more sub but not workd
Sub Worksheet_Change(ByVal Target As Range)
'Specify the target cell whose entry shall be the sheet tab name.
If Target.Address <> "$A$2" Then Exit Sub
'If the target cell is empty (contents cleared) then do not change the shet name
If IsEmpty(Target) Then Exit Sub
'If the length of the target cell's entry is greater than 31 characters, disallow the entry.
If Len(Target.Value) > 21 Then
MsgBox "Worksheet tab names cannot be greater than 31 characters in length." & vbCrLf & _
"You entered " & Target.Value & ", which has " & Len(Target.Value) & " characters.", , "Keep it under 21 characters"
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
Exit Sub
End If
'Sheet tab names cannot contain the characters /, \, [, ], *, ?, or :.
'Verify that none of these characters are present in the cell's entry.
Dim IllegalCharacter(1 To 7) As String, i As Integer
IllegalCharacter(1) = "/"
IllegalCharacter(2) = "\"
IllegalCharacter(3) = "["
IllegalCharacter(4) = "]"
IllegalCharacter(5) = "*"
IllegalCharacter(6) = "?"
IllegalCharacter(7) = ":"
For i = 1 To 7
If InStr(Target.Value, (IllegalCharacter(i))) > 0 Then
MsgBox "You used a character that violates sheet naming rules." & vbCrLf & vbCrLf & _
"Please re-enter a sheet name without the ''" & IllegalCharacter(i) & "'' character.", 48, "Not a possible sheet name !!"
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
Exit Sub
End If
Next i
'Verify that the proposed sheet name does not already exist in the workbook.
Dim strSheetName As String, wks As Worksheet, bln As Boolean
strSheetName = Trim(Target.Value)
On Error Resume Next
Set wks = ActiveWorkbook.Worksheets(strSheetName)
On Error Resume Next
If Not wks Is Nothing Then
bln = True
Else
bln = False
Err.Clear
End If
'If the worksheet name does not already exist, name the active sheet as the target cell value.
'Otherwise, advise the user that duplicate sheet names are not allowed.
If bln = False Then
ActiveSheet.Name = strSheetName
Else
MsgBox "There is already a sheet named " & strSheetName & "." & vbCrLf & _
"Please enter a unique name for this sheet."
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
End If
End Sub
Something like this should do what you want.
Sub RenameSheet()
Dim xWs As Worksheet
Dim xRngAddress As String
Dim xName As String
xRngAddress = Application.ActiveCell.Address
For Each xWs In Application.ActiveWorkbook.Sheets
xName = xWs.Range(xRngAddress).Value
If xName <> "" Then
xWs.Name = xName
End If
Next
End Sub
In my workbook there are 50 worksheets, I have created a userform which pop up a textbox which can help me change the sheet name now I want that when I toggle through different worksheets then the current worksheet name should display in that textbox and then I will modify the sheet name with the code which is stated below.
Can you please tell me a code line with the help of which the textbox displays the current worksheet name.
Please find below the code with the help of which I can change the existing worksheet name by typing the name in the textbox Sheetnametext
Private Sub Sheetnametext_Change()
'If the length of the entry is greater than 31 characters, disallow the entry.
If Len(Sheetnametext) > 31 Then
MsgBox "Worksheet tab names cannot be greater than 31 characters in length." & vbCrLf & "You entered " & mysheetname & ", which has " & Len(mysheetname) & " characters.", , "Keep it under 31 characters"
Exit Sub
End If
'Sheet tab names cannot contain the characters /, \, [, ], *, ?, or :. 'Verify that none of these characters are present in the cell's entry.
Dim IllegalCharacter(1 To 7) As String, i As Integer
IllegalCharacter(1) = "/"
IllegalCharacter(2) = "\"
IllegalCharacter(3) = "["
IllegalCharacter(4) = "]"
IllegalCharacter(5) = "*"
IllegalCharacter(6) = "?"
IllegalCharacter(7) = ":"
For i = 1 To 7
If InStr(Sheetnametext, (IllegalCharacter(i))) > 0 Then
MsgBox "You used a character that violates sheet naming rules." & vbCrLf & vbCrLf & "Please re-enter a sheet name without the ''" & IllegalCharacter(i) & "'' character.", 48, "Not a possible sheet name !!"
Exit Sub
End If
Next i
'Verify that the proposed sheet name does not already exist in the workbook.
Dim strSheetName As String, wks As Worksheet, bln As Boolean
strSheetName = Trim(Sheetnametext)
On Error Resume Next
Set wks = ActiveWorkbook.Worksheets(strSheetName)
On Error Resume Next
If Not wks Is Nothing Then
bln = True
Else
bln = False
Err.Clear
End If
'History is a reserved word, so a sheet cannot be named History.
If UCase(mysheetname) = "HISTORY" Then
MsgBox "A sheet cannot be named History, which is a reserved word.", 48, "Not allowed"
Exit Sub
End If
'If the worksheet name does not already exist, name the active sheet as the InputBox entry.
'Otherwise, advise the user that duplicate sheet names are not allowed.
If bln = False Then
ActiveSheet.Name = strSheetName
End If
End Sub
Astha better you use a Listbox to navigate Sheets in Workbook,, try this code.
Private Sub UserForm_Initialize()
Dim N As Long
For N = 1 To ActiveWorkbook.Sheets.Count ListBox1.AddItem ActiveWorkbook.Sheets(N).Name
Next N
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