I've seen some examples of how to get multiple ranges as a function parameter, but given my data structure, I haven't been able to get this to work.
When the mouse is on Age, for example, and the function is run, it is to grab the highlighted cells as a range, since I'll be using these data for charts.
Here's how the data is:
Here's the piece of code that deals with the data CURRENTLY - if those cells are manually selected and the script is run.
Public Sub sMigrateFixToList(blnTranspose As Boolean, _
strMigrationType As String, _
MultiRng As Range)
Dim strProcedure As String
Dim lngLastRow As Long
Dim strDestRange As String
Dim lngNumRows As Long
Dim lngNumCols As Long
Dim k As Long
Dim t As Long
' Enable Error Handler
On Error GoTo Err_Handler
' Name Proc for Error Handler Mesasage
strProcedure = "sMigrateToList"
If ActiveSheet.Name <> "Sheet1" Then
Call MsgBox("Go to the right sheet")
GoTo Exit_Proc:
End If
Application.ScreenUpdating = False
k = MigrationList.UsedRange.Rows.Count
t = IIf(k = 1, 2, k + 2)
objRange.Copy
MigrationList.Cells(t, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=blnTranspose
Select Case strMigrationType
Case "T"
MigrationList.Cells(t - 1, 1).Value2 = "<<TABLE>>"
End Select
Application.ScreenUpdating = True
Exit_Proc:
On Error Resume Next
Exit Sub
Err_Handler:
Select Case Err.Number
Case 1004
Err.Clear
Call MsgBox("Não pode selecionar blocos de células não alinhados.", _
vbInformation + vbOKOnly, _
g_STR_ERRMESSTITLECRITICAL)
Case Else
Call MsgBox("Error number: " & Err.Number & vbCrLf & _
"Description: " & Err.Description & vbCrLf & _
"Code: " & strProcedure, _
vbCritical + vbOKOnly, _
g_STR_ERRMESSTITLECRITICAL)
End Select
Resume Exit_Proc
End Sub
The idea is to have this range made of multiple ranges fixed and pass it to other function being called below as a parameter:
Public Sub sMigrateToListAsTable()
Call sMigrateToList(False, "T", Selection)
End Sub
Thank you!
Related
I found the following code to take the data on the TrialBalance worksheet and convert it into a table. It creates the table and renames it, but the range needs to start at A2 where my table heading are stored.
Sub ConvertTrialBalanceToTable()
Dim wb1 As Workbook
Set wb1 = ActiveWorkbook 'Trial Balance Template File
wb1.Sheets("TrialBalance").Range("A2").CurrentRegion.Select
If ActiveSheet.ListObjects.Count < 1 Then
ActiveSheet.ListObjects.Add.Name = ActiveSheet.Name
End If
End Sub
Convert 'CurrentRegion' to Excel Table When Occupied Rows Above or Columns to the Left of First Cell
If the code is in the TrialBalance template file, use ThisWorkbook instead of ActiveWorkbook.
Sub ConvertTrialBalanceToTable()
With ActiveWorkbook.Worksheets("TrialBalance")
If .ListObjects.Count = 0 Then
.ListObjects.Add(xlSrcRange, _
RefCurrentRegion(.Range("A2")), , xlYes).Name = .Name
End If
End With
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns a reference to the range starting with the first cell
' of a range and ending with the last cell of the first cell's
' Current Region.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCurrentRegion( _
ByVal FirstCell As Range) _
As Range
Const ProcName As String = "RefCurrentRegion"
On Error GoTo ClearError
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1).CurrentRegion
Set RefCurrentRegion = FirstCell.Resize(.Row + .Rows.Count _
- FirstCell.Row, .Column + .Columns.Count - FirstCell.Column)
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
This is a scirpt which is supposed to add picture into a Powerpoint Placeholders based on the value of selected cells in an Excel File. Whenever there is an error, the script is supposed to go to the error handling line, fixed it and resume back from where the error was.
However, when the script encounters an error, it will run the error handling line, then end sub. How can I make it resume from where the error was detected?
For example, let's say we have an error on this line
On Error GoTo ERIB
For IB = 6
The script will go to error handling
ERIB:
oSld1.Shapes.AddPicture( _
FileName:="D:\Users\Transparent\AnorMale.png", _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, Left:=50, Top:=30, Width:=100, Height:=50).Select
After the above code, it will proceed to line ERIE then End Sub.
Instead, I would like the script to continue running from For IB = 7 until the end of the script.
Here's the code
Dim I As Integer
Dim oXL As Object 'Excel.Aplication
Dim OWB As Object 'Excel.workbook
Dim oSld1 As Slide
Dim oSld2 As Slide
Set oXL = CreateObject("Excel.Application")
Set OWB = oXL.Workbooks.Open(FileName:="D:\Users\1. Working\Working.xlsm")
Set oSld1 = ActivePresentation.Slides(1)
Set oSld2 = ActivePresentation.Slides(2)
------------------------------------------------------------------------
On Error GoTo ERIB
For IB = 5 To 7
oSld1.Shapes.AddPicture( _
FileName:="D:\Users\Transparent\" & OWB.Sheets("Listing").Range("B" & CStr(IB)).Value & "_hof.png", _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, Left:=50, Top:=30, Width:=100, Height:=50).Select
Next IB
On Error GoTo ERIE
For IE = 5 To 7
oSld2.Shapes.AddPicture( _
FileName:="D:\Users\Transparent\" & OWB.Sheets("Listing").Range("E" & CStr(IE)).Value & "_hof.png", _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, Left:=50, Top:=30, Width:=100, Height:=50).Select
Next IE
OWB.Close
oXL.Quit
Set OWB = Nothing
Set oXL = Nothing
Exit Sub
ERIB:
oSld1.Shapes.AddPicture( _
FileName:="D:\Users\Transparent\AnorMale.png", _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, Left:=50, Top:=30, Width:=100, Height:=50).Select
ERIE:
oSld1.Shapes.AddPicture( _
FileName:="D:\Users\Transparent\AnorMale.png", _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, Left:=50, Top:=30, Width:=100, Height:=50).Select
End Sub
You can simply put an statement Resume Next at the end of your error handler:
Sub test1()
Dim myValues, sum As Long, count As Long, i As Long
myValues = Array(2, 4, "A", 5, 10)
On Error GoTo ERRHANDLER
For i = LBound(myValues) To UBound(myValues)
sum = sum + myValues(i)
count = count + 1
Next i
Debug.Print "Sum: " & sum & " Count: " & count
Exit Sub
ERRHANDLER:
Debug.Print "error: " & Err.Number, Err.Description
Resume Next
End Sub
Or you can jump to a label:
Sub test2()
Dim myValues, sum As Long, count As Long, i As Long
myValues = Array(2, 4, "A", 5, 10)
On Error GoTo ERRHANDLER
For i = LBound(myValues) To UBound(myValues)
sum = sum + myValues(i)
count = count + 1
CONTINUELOOP:
Next i
Debug.Print "Sum: " & sum & " Count: " & count
Exit Sub
ERRHANDLER:
Debug.Print "error: " & Err.Number, Err.Description
Resume CONTINUELOOP
End Sub
However, consider two things:
a) if you already expect that something specific might fail (in your case adding the picture), it's maybe better to handle that locally. If your main problem is that the AddPicture fails because the image fail is missing, you should check the existance to avoid the error (use for example the Dir-command).
Sub test3()
Dim myValues, sum As Long, count As Long, i As Long
myValues = Array(2, 4, "A", 5, 10)
For i = LBound(myValues) To UBound(myValues)
On Error Resume Next
sum = sum + myValues(i)
If Err.Number <> 0 Then
If Err.Number <> 13 Then Err.Raise Err.Number ' An error occurred and it wasn't Type mismatch
Err.Clear
Else
count = count + 1
End If
On Error Goto 0
Next i
Debug.Print "Sum: " & sum & " Count: " & count
Exit Sub
End Sub
b) You need to be careful what you do in your error handler: If the AddPicture in the error handler fails, it will raise another error and this time it will not be caught. Consider to write a MyAddPicture-routine that does the error handling internally without affecting the rest of your code.
You should consider using a try function so that you encapsulate the error and don't have to go jumping all over the place.
The code below compiles without error but as I don't have your images it hasn't been tested.
Sub Test()
Dim I As Integer
Dim oXL As Object 'Excel.Aplication
Dim OWB As Object 'Excel.workbook
Dim oSld1 As Slide
Dim oSld2 As Slide
Set oXL = CreateObject("Excel.Application")
Set OWB = oXL.Workbooks.Open(Filename:="D:\Users\1. Working\Working.xlsm")
Set oSld1 = ActivePresentation.Slides(1)
Set oSld2 = ActivePresentation.Slides(2)
Dim myParams As Variant
myParams = Array("", msoTrue, msoTrue, 50, 30, 100, 50)
Dim mySLide As PowerPoint.Slide
Const myError As Long = 42 ' put your own error number here
'------------------------------------------------------------------------
For IB = 5 To 7
myParams(0) = "D:\Users\Transparent\" & OWB.Sheets("Listing").Range("B" & CStr(IB)).Value & "_hof.png"
If Not TryAddPictureToSlide(oSld1, myParams, mySLide) Then
myParams(0) = "D:\Users\Transparent\AnorMale.png"
If Not TryAddPictureToSlide(oSld1, myParams, mySLide) Then
Err.Raise _
myError, _
"Could not add " & myParams(0)
End If
End If
'Do whatever needs to be done with myShape
Next IB
For IE = 5 To 7
myParams(0) = "D:\Users\Transparent\" & OWB.Sheets("Listing").Range("E" & CStr(IE)).Value & "_hof.png"
If Not TryAddPictureToSlide(oSld2, myParams, mySLide) Then
myParams(0) = "D:\Users\Transparent\AnorMale.png"
If Not TryAddPictureToSlide(oSld2, myParams, mySLide) Then
Err.Raise _
myError, _
"Could not add " & "D:\Users\Transparent\" & OWB.Sheets("Listing").Range("E" & CStr(IE)).Value & "_hof.png"
End If
End If
Next
'Do whatever needs to be done with myShape
OWB.Close
oXL.Quit
Set OWB = Nothing
Set oXL = Nothing
End Sub
Public Function TryAddPictureToSlide(ByRef ipSlide As PowerPoint.Slide, ByRef ipParams As Variant, opShape As PowerPoint.Shape) As Boolean
On Error Resume Next
Set opShape = _
ipSlide.Shapes.AddPicture _
( _
Filename:=ipParams(0), _
LinkToFile:=ipParams(1), _
SaveWithDocument:=ipParams(2), _
Left:=ipParams(3), _
Top:=ipParams(4), _
Width:=ipParams(5), _
Height:=ipParams(6))
TryAddPictureToSlide = Err.Number = 0
Err.Clear
End Function
I have a handy function that's called from cell C1 that populates the cell with the filters that have been applied to Column C using the filters dropdown: =ShowColumnFilter(C:C)
As soon as the user clicks OK in the dropdown, the cell displays the filter(s).
However, when I apply a filter to that same column using VBA below from a command button or hyperlink, the column is correctly filtered but the Function ShowColumnFilter returns an error.
'Code Snippet:
With ActiveSheet.Range("A:W")
.AutoFilter Field:=3, Criteria1:="Some Criteria Here"
End With
Function ShowColumnFilter(rng as Range)
'Only the relevant code included here. Works fine when filtering through dropdown, but gives error after applying filter through the VBA in Worksheet_FollowHyperlink.
Dim sh As Worksheet
Dim frng As Range
Set sh = rng.Parent
Debug.Print sh.FilterMode
'When filtered from UI dropdown OR after executing VBA Code Snippet from Worksheet_FollowHyperlink returns TRUE
Debug.Print sh.AutoFilter.FilterMode
'When filtered from UI dropdown returns TRUE but after executing VBA from hyperlink or command button creates an error: "Object variable or With block variable not set"
Set frng = sh.AutoFilter.Range 'Errors only after filtering by executing VBA from separate routine
...
End Function
This one has me perplexed because the function ShowColumnFilter is populating a cell and is not invoked directly by another sub. I'm trying to populate C1 with the filtering that has been applied to the column regardless of how the user filtered it. Any help is greatly appreciated.
Full code here:
Function ShowColumnFilter(rng As Range)
On Error GoTo myErr
'> PURPOSE: Show filters used in a specific column _
USAGE: =ShowColumnFilter(C:C)
Dim filt As Filter
Dim sCrit1 As String
Dim sCrit2 As String
Dim sOp As String
Dim lngOp As Long
Dim lngOff As Long
Dim frng As Range
Dim sh As Worksheet
Dim i As Long
Set sh = rng.Parent
If sh.FilterMode = False Then
ShowColumnFilter = "No Active Filter"
Exit Function
End If
'**** Included only for debugging *****
Debug.Print sh.FilterMode
Debug.Print sh.AutoFilter.FilterMode
'**************************************
Set frng = sh.AutoFilter.Range
If Intersect(rng.EntireColumn, frng) Is Nothing Then
ShowColumnFilter = CVErr(xlErrRef)
Else
lngOff = rng.Column - frng.Columns(1).Column + 1
If Not sh.AutoFilter.Filters(lngOff).On Then
ShowColumnFilter = "No Conditions"
Else
Set filt = sh.AutoFilter.Filters(lngOff)
On Error Resume Next
lngOp = filt.Operator
If lngOp = xlFilterValues Then
For i = LBound(filt.Criteria1) To UBound(filt.Criteria1)
sCrit1 = sCrit1 & filt.Criteria1(i) & " or "
Next i
sCrit1 = Left(sCrit1, Len(sCrit1) - 3)
Else
sCrit1 = filt.Criteria1
sCrit2 = filt.Criteria2
If lngOp = xlAnd Then
sOp = " And "
ElseIf lngOp = xlOr Then
sOp = " or "
Else
sOp = ""
End If
End If
ShowColumnFilter = sCrit1 & sOp & sCrit2
End If
End If
myExit:
Exit Function
myErr:
Call ErrorLog(Err.Description, Err.Number, "GlobalCode", "ShowColumnFilter", True)
Resume myExit
End Function
Sub ErrorLog(strErrDescription As String, lngErrNumber As Long, strSheet As String, strSubName As String, bolShowError As Boolean)
On Error GoTo myErr
'> PURPOSE: Record Errors in an Error Log
If bolShowError = True Then _
MsgBox "An error has occured running " & strSubName & " on worksheet " & strSheet & ": " & Err.Number & " - " & Err.Description, vbInformation, "VBA Error"
myExit:
Exit Sub
myErr:
MsgBox "VBA Error - Error Log: " & Err.Number & " - " & Err.Description
Resume myExit
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
On Error GoTo myErr
'> PURPOSE: Fires whenever a hyperlink is clicked on Sheet 1
Dim sValue as String
sValue = "Some Useful Criteria"
'> Select the sheet:
Sheets("MySheetName").Select
With ActiveSheet.Range("A:W")
If Len(sValue) > 0 Then _
.AutoFilter Field:=3, Criteria1:=sValue
End With
'> Go to the top row:
ActiveWindow.ScrollRow = 1
myExit:
Exit Sub
myErr:
Call ErrorLog(Err.Description, Err.Number, "Sheet1", "FollowHyperlink", True)
Resume myExit
End Sub
It looks like the problem you're running into is linked to exactly when your ShowColumnFilter function is running. As a UDF, it's executed when the worksheet is recalculated. Applying an AutoFilter kicks off a recalculation. So if you catch the call stack in your Worksheet_FollowHyperlink routine, you can detect that the ShowColumnFilter function is entered immediately following the .AutoFilter Field:=3, Criteria1:=sValue statement. So your function is actually catching the worksheet and the filter in a somewhat unknown state.
I was able to solve this issue by protecting that section of code by disabling events and automatic calculations:
Sub ApplyTestFilter()
'Hyperlink Code Snippet:
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
With ActiveSheet.Range("A:W")
.AutoFilter Field:=2, Criteria1:=">500"
End With
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
This forces the automatic calculations to delay until you've completed your filtering. (NOTE: in some cases you might have to explicitly force the worksheet to recalculate, though I didn't encounter that situation in my small test.)
New to all this but appreciate any help I can get.
Problem: I have a duty roster with initials and sometimes I want to highlight a specific person to see his/her schedule. The highlight consists of changing the font color and making it bold but I'd also like the cell color to change as well, to lets say light green. I do know that I can use the Search/Replace feature but I'd like a macro for this.
So far, I've managed to piece together an input box and I can change the font color and add 'bold' to the font (and other changes) but I haven't solved changing the cell color.
This is what I have so far:
Sub FindAndBold()
Dim sFind As String
Dim rCell As Range
Dim rng As Range
Dim lCount As Long
Dim iLen As Integer
Dim iFind As Integer
Dim iStart As Integer
On Error Resume Next
Set rng = ActiveSheet.UsedRange. _
SpecialCells(xlCellTypeConstants, xlTextValues)
On Error GoTo ErrHandler
If rng Is Nothing Then
MsgBox "There are no cells with text"
GoTo ExitHandler
End If
sFind = InputBox( _
Prompt:="Skriv in dina initialer", _
Title:="Dina initialer")
If sFind = "" Then
MsgBox "Du skrev inget"
GoTo ExitHandler
End If
iLen = Len(sFind)
lCount = 0
For Each rCell In rng
With rCell
iFind = InStr(.Value, sFind)
Do While iFind > 0
.Characters(iFind, iLen).Font.Bold = True
.Characters(iFind, iLen).Font.Color = RGB(255, 0, 0)
.Characters(iFind, iLen).Font.ColorIndex = 4
lCount = lCount + 1
iStart = iFind + iLen
iFind = InStr(iStart, .Value, sFind)
Loop
End With
Next
If lCount = 0 Then
MsgBox "Fanns inget" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "att markera"
ElseIf lCount = 1 Then
MsgBox "Det fanns en" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "markerades"
Else
MsgBox lCount & " hittade" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "och markerades"
End If
ExitHandler:
Set rCell = Nothing
Set rng = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
Any help would be greatly appreciated!
(The text in the prompt and response is in Swedish)
You can also do this using conditional formatting, no need for VBS.
Using a conditional format formula you can enter something like this: =AND(ISNUMBER(SEARCH($G$1;A2));$G$1<>"") - in this case field G1 would be the field used for searching (read:highlighting) all the fields containing this condition.
If you desire a VBS we can improve and include a filter for all lines matching your search:
Sub searchfilter()
Range("A11:M10000").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Range("A2:M13"), Unique:=False
End Sub
And to clear:
Sub clearfilter()
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
End Sub
Assign both macros to a button.
Sample image where i combined both (filter was done on C15 in this case):
And sample with hidden fields shown:
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