Hyperlink link of the Image from userform added wont open - excel

Hi i have userform with the all the data adds to the "VehicleRejected" Sheet from a userform however i have added an code for user to select an image from their drive and it will add the hyperlink to the cell now hyperlink wont open and error message comes up with "Cannot open the Specific file" can someone help me with the code please
Private Sub CommandButton3_Click()
On Error GoTo errHandler:
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("VehicleRejected")
Dim n As Long
Dim answer As String
Dim strFileName As String
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
Application.EnableEvents = False
''''''''''''''''''''
n = sh.Range("A" & Application.Rows.Count).End(xlUp).Row
strFileName = Application.GetOpenFilename(filefilter:="Tiff Files(*.tif;*.tiff),*.tif;*.tiff,JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", FilterIndex:=2, Title:="Select a File", MultiSelect:=False)
TextBox65 = strFileName 'use to save URL or Link from picture
If strFileName = "False" Then
MsgBox "File Not Selected!"
Else
'load picture to Image control, using LoadPicture property
Me.Image2.Picture = LoadPicture(strFileName)
End If
sh.Unprotect "1234"
sh.Range("i" & n + 1).Value = Me.TextBox65.Value
sh.Range("i" & n + 1).Select
With ActiveSheet
.Hyperlinks.Add Anchor:=sh.Range("i" & n + 1), Address:=",TextToDisplay, """
End With
sh.Protect "1234"
MsgBox "Updated Successfully!!!", vbInformation
Unload Me
Application.EnableEvents = True
Application.ScreenUpdating = True
Worksheets("VehicleRejected").Activate
Worksheets("VehicleRejected").Cells(1, 3).Select
Exit Sub
errHandler:
MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " _
& Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Please Contact Admin", vbCritical, "Error Message"
End Sub

i want to know if it is possible for image that uploaded on the userform which is in image2 can it be also inserted on to the sheet in column I, J, K , L on same row as the date entered with auto size adjusted.
Yes it is possible. Here is an example. I am going to insert the image in say I10 for demonstration purpose. Feel free to adapt it to suit your need.
Logic:
Get user's temp directory.
Save the image from the image control to user's temp directory using SavePicture.
Insert the image from the temp directory into relevant worksheet.
Resize as required.
Code:
Option Explicit
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH As Long = 260
Private Sub CommandButton1_Click()
Dim ws As Worksheet
'~~> Change this to the relevant sheet
Set ws = Sheet1
Dim tempImagePath As String
tempImagePath = TempPath & "Temp.jpg"
'~~> Save the image to user's temp directory
SavePicture Image1.Picture, tempImagePath
DoEvents
'~~> Insert the image in cell say I10 and resize it
With ws.Pictures.Insert(tempImagePath)
'~~> If LockAspectRatio is set to true then Height and Width will not change
'~~> as per cell height and width
.ShapeRange.LockAspectRatio = msoFalse
.Left = ws.Range("I10").Left
.Top = ws.Range("I10").Top
.Width = ws.Range("I10").Width
.Height = ws.Range("I10").Height
End With
End Sub
Function TempPath() As String
TempPath = String$(MAX_PATH, Chr$(0))
GetTempPath MAX_PATH, TempPath
TempPath = Replace(TempPath, Chr$(0), "")
End Function
In Action:
Image attribution

Hi Siddharth with your code and with some other code played around, below is what i have got so far and it adds the hyperlink of the picture however file wont open or found.
Private Sub CommandButton3_Click()
On Error GoTo errHandler:
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("VehicleRejected")
Dim n As Long
Dim answer As String
Dim strFileName As String
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
Application.EnableEvents = False
''''''''''''''''''''
n = sh.Range("A" & Application.Rows.Count).End(xlUp).Row
strFileName = Application.GetOpenFilename(filefilter:="Tiff Files(*.tif;*.tiff),*.tif;*.tiff,JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", FilterIndex:=2, Title:="Select a File", MultiSelect:=False)
TextBox65 = strFileName 'use to save URL or Link from picture
If strFileName = "False" Then
MsgBox "File Not Selected!"
Else
'load picture to Image control, using LoadPicture property
Me.Image2.Picture = LoadPicture(strFileName)
End If
sh.Unprotect "1234"
sh.Range("i" & n + 1).Value = Me.TextBox65.Value
sh.Range("i" & n + 1).Select
With ActiveSheet
.Hyperlinks.Add Anchor:=sh.Range("i" & n + 1), Address:=",TextToDisplay, """
End With
sh.Protect "1234"
MsgBox "Updated Successfully!!!", vbInformation
Unload Me
Application.EnableEvents = True
Application.ScreenUpdating = True
Worksheets("VehicleRejected").Activate
Worksheets("VehicleRejected").Cells(1, 3).Select
Exit Sub
errHandler:
MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " _
& Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Please Contact Admin", vbCritical, "Error Message"
End Sub

Related

Looping for dynamic pictures

So I have created a dynamic selection list for excel using vba. see below
Below is the code
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Address = "$A$2" Then
Call PanggilPhoto
End If
End Sub
Sub PanggilPhoto()
Application.ScreenUpdating = False
Dim myObj
Dim Foto
Set myObj = ActiveSheet.DrawingObjects
For Each Foto In myObj
If Left(Foto.Name, 7) = "Picture" Then
Foto.Select
Foto.Delete
End If
Next
Dim CommodityName1 As String, CommodityName2 As String, T As String
myDir = ThisWorkbook.Path & "\"
CommodityName1 = Range("A2")
T = ".png"
Range("C15").Value = CommodityName
On Error GoTo errormessage:
ActiveSheet.Shapes.AddPicture Filename:=myDir & CommodityName1 & T, _
linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=190, Top:=10, Width:=140,
Height:=90
errormessage:If Err.Number = 1004 Then
Exit Sub
MsgBox "File does not exist." & vbCrLf & "Check the name of the Commodity!"
Range("A2").Value = ""
Range("C10").Value = ""
End If
Application.ScreenUpdating = True
End Sub
foto is a predefined data list in the sheet.
So the question is instead of doing it for one cell how can I create a loop of some sort to do it for multiple cells? I need it to import mulitple images on one macro run
found a solution
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Address = "$A$2" Then
Call schedules
End If
End Sub
Sub schedules()
Worksheets("Picture").Activate
Application.ScreenUpdating = False
Dim myObj
Dim Foto
Set myObj = ActiveSheet.DrawingObjects
For Each Foto In myObj
If Left(Foto.Name, 7) = "Picture" Then
Foto.Select
Foto.Delete
End If
Next
Dim CommodityName1 As String, CommodityName2 As String, T1 As String, T2 As String
Dim i As Integer, j As Integer, k As Integer
j = 0
For i = 2 To 100
myDir = "C:\Users\User\Desktop\ESTIMATING SHEETS\test\rebar shapes" & "\"
CommodityName1 = Range("A" & i)
T1 = ".png"
On Error GoTo errormessage:
ActiveSheet.Shapes.AddPicture Filename:=myDir & CommodityName1 & T1, _
linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=230, Top:=j, Width:=140, Height:=80
errormessage:
If Err.Number = 1004 Then
Exit Sub
MsgBox "File does not exist." & vbCrLf & "Check the name of the rebar!"
Range("A" & i).Value = ""
Range("C10").Value = ""
End If
Application.ScreenUpdating = True
i = i + 11
j = j + 190
Next i
End Sub

How to attach files and store them in cells?

I'm trying to attach files and store them in cells G2 and on.
However, every time I input it gets input in G2. If a user decides to enter more data the input data will iterate into a new row but the attachment stays in row G2 and takes the place of the previous one.
textbox2 in userform gets skipped every time I press enter. I want my users to navigate with keyboards but if I'm done in textbox1 and press enter it will throw me to textbox3 rather than textbox2.
Private Sub SubmitButton_Click()
Dim iRow As Long
Dim wrkSht As Worksheet
Set wrkSht = Worksheets("Sheet1")
Dim emailApplication As Object
Dim emailItem As Object
iRow = wrkSht.Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
If Trim(RequesterBox.Value) = "" Then
RequesterBox.SetFocus
MsgBox "Please complete the form"
Exit Sub
End If
wrkSht.Cells(iRow, 1).Value = RequesterBox.Value
wrkSht.Cells(iRow, 2).Value = SquadronBox.Value
wrkSht.Cells(iRow, 3).Value = EmailBox.Value
wrkSht.Cells(iRow, 4).Value = PhoneBox.Value
wrkSht.Cells(iRow, 5).Value = LocationBox.Value
wrkSht.Cells(iRow, 6).Value = DescriptionBox.Value
MsgBox "Request has been added Succesfully. Thanks for you submition, someone will be contacting you shortly", vbOKOnly + vbInformation, "Thanks"
'----------------------- Send Email-----------------------'
Set emailApplication = CreateObject("Outlook.Application")
Set emailItem = emailApplication.CreateItem(0)
emailItem.To = ""
emailItem.Subject = "Facility Request"
emailItem.Body = "A request for " & LocationBox.Value & " has been submited with the following description: " & Chr(10) & _
DescriptionBox.Value
emailItem.Display
Set emailItem = Nothing
Set emailItemApplication = Nothing
RequesterBox.Value = ""
SquadronBox.Value = ""
EmailBox.Value = ""
PhoneBox.Value = ""
LocationBox.Value = ""
DescriptionBox.Value = ""
RequesterBox.SetFocus
End Sub
Private Sub AttachButton_Click()
Set wrkSht = Worksheets("Sheet1")
Dim LinksList As Range
Dim iRow As Long
Dim LinkAttached As Long
Set LinksList = Range("G2")
Sheet1.Range("G2").Select
'declare last row to insert link to
lastRowLink = WorksheetFunction.CountA(Sheets("Sheet1").Range("G:G"))
Sheets("Sheet1").Cells(lastRow + 1, 11).Value = LinkAttached
ChDrive "C:\"
ChDir "C:\"
Filt = "PNG Files(*.png),*.png ," & _
"Jpeg Files(*.jpeg),*.jpg ," & _
"PDF Files (*.pdf),*.pdf ," & _
"All Files (*.*),*.*"
FilterIndex = 1
Title = "Select a File to Hyperlink"
FileName = Application.GetOpenFilename _
(FileFilter:=Filt, _
FilterIndex:=FilterIndex, _
Title:=Title)
If FileName <> False Then
wrkSht.Hyperlinks.Add Anchor:=LinksList, _
Address:=FileName, _
TextToDisplay:=FileName
Else
MsgBox "No file was selected.", vbCritical, "Loading Error"
Exit Sub
End If
End Sub
Hy i hope it will help you
Private Sub AttachButton2_Click()
Dim lastRow As Long, nextId As Long
Dim ws As Worksheet
Dim newRecord As Range
Set ws = ThisWorkbook.Worksheets("Sheet1")
With ws
'getlcurrent last row
lastRow = .Cells(.Rows.Count, "G").End(xlUp).Row
'get next Id
nextId = Val(.Range("G" & lastRow).Value) + 1
'set new record
Set newRecord = .Range("G" & lastRow + 1)
'insert data
newRecord.Value = nextId
'select file
ChDrive "C:\"
ChDir "C:\"
Filt = "PNG Files(*.png),*.png ," & _
"Jpeg Files(*.jpeg),*.jpg ," & _
"PDF Files (*.pdf),*.pdf ," & _
"All Files (*.*),*.*"
FilterIndex = 1
Title = "Select a File to Hyperlink"
Filename = Application.GetOpenFilename _
(FileFilter:=Filt, _
FilterIndex:=FilterIndex, _
Title:=Title)
If Filename <> False Then
.Hyperlinks.Add Anchor:=newRecord, _
Address:=Filename, _
TextToDisplay:=Filename
Else
MsgBox "No file was selected.", vbCritical, "Loading Error"
Exit Sub
End If
End With
End Sub

Sending Data from Word Into Excel: Run-time error: '424' Object Required

I am trying to send data to Excel from Word after an email is sent. I have the email and the rest of it working. Now, I am trying to get the part with Excel working.
Private Sub btnGenerateEmail_Click()
'Instatiate Application Objects (using late binding)
Dim App As Object
Dim Msg As Object
Const olMailItem As Long = 0
'Declare Form Variables
Dim EmplName As String: EmplName = Me.frmEmployeeName
Dim IncidentDesc As String: IncidentDesc = Me.frmIncidentDescription
Dim EmplTrain As String: EmplTrain = Me.frmEmployeeTraining
Dim FaceOnRack As String: FaceOnRack = Me.frmFaceOnRack
Dim DrawingProb As String: DrawingProb = Me.frmDrawingProblem
Dim JobNum As String: JobNum = Me.frmJobNumber
Dim DrwNum As String: DrwNum = Me.frmDrawingNumber
Dim FaceDesc As String: FaceDesc = Me.frmFaceDescription
Dim Qty As String: Qty = Me.frmQty
Dim StockOrNon As String: StockOrNon = Me.frmStockOrNon
Dim FaceReplace As String: FaceReplace = Me.frmFaceReplace
'Set Application Objects (using late binding)
Set App = CreateObject("Outlook.Application")
Set Msg = App.CreateItem(olMailItem)
'Data validation
If IsNull(EmplName) Or EmplName = "" Then
MsgBox ("Please enter the employee's name."), vbCritical
Exit Sub
End If
If IsNull(IncidentDesc) Or IncidentDesc = "" Then
MsgBox ("Please describe how the face was broken."), vbCritical
Exit Sub
End If
If IsNull(EmplTrain) Or EmplTrain = "" Then
MsgBox ("Does the employee need more training to avoid these kind of incidents in the future?"), vbCritical
Exit Sub
End If
If IsNull(FaceOnRack) Or FaceOnRack = "" Then
MsgBox ("Was the already broken when on rack?"), vbCritical
Exit Sub
End If
If IsNull(DrawingProb) Or DrawingProb = "" Then
MsgBox ("Was the face scrapped because of an issue with the drawing/art?"), vbCritical
Exit Sub
End If
If IsNull(JobNum) Or JobNum = "" Then
MsgBox ("Please enter the job number or traveler number."), vbCritical
Exit Sub
End If
If IsNull(DrwNum) Or DrwNum = "" Then
MsgBox ("Please enter the drawing number."), vbCritical
Exit Sub
End If
If IsNull(FaceDesc) Or FaceDesc = "" Then
MsgBox ("Please enter a description of the face being scrapped."), vbCritical
Exit Sub
End If
If IsNull(Qty) Or Qty = "" Then
MsgBox ("Please enter the quantity being scrapped."), vbCritical
Exit Sub
End If
If IsNull(StockOrNon) Or StockOrNon = "" Then
MsgBox ("Is the face stock or non-stock?"), vbCritical
Exit Sub
End If
If IsNull(FaceReplace) Or FaceReplace = "" Then
MsgBox ("Does this face need to be replaced?"), vbCritical
Exit Sub
End If
'Compose HTML Message Body
Dim HTMLContent As String
HTMLContent = "<p style='font-family:Calibri; font-size:14px;'>This email is an autogenerated scrap face incident report.</p>" _
& "<table style='font-family:Calibri; font-size:14px;' width='75%' border='1' bordercolor='black' cellpadding='5'>" _
& "<tr><td width='65%'>Employee Name</td><td>" & EmplName & "</td></tr>" _
& "<tr><td>How was the face broken?</td><td>" & IncidentDesc & "</td></tr>" _
& "<tr><td>Does employee in question need more training to prevent future incidents?</td><td>" & EmplTrain & "</td></tr>" _
& "<tr><td>Was the face found on the rack already broken?</td><td>" & FaceOnRack & "</td></tr>" _
& "<tr><td>Was the face scrapped because of an issue with the drawing/art?</td><td>" & DrawingProb & "</td></tr>" _
& "<tr><td>Job/Traveler Number:</td><td>" & JobNum & "</td></tr>" _
& "<tr><td>Drawing Number:</td><td>" & DrwNum & "</td></tr>" _
& "<tr><td>Face Description:</td><td>" & FaceDesc & "</td></tr>" _
& "<tr><td>Quantity</td><td>" & Qty & "</td></tr>" _
& "<tr><td>Stock or Non-Stock</td><td>" & StockOrNon & "</td></tr>" _
& "<tr><td>Does this face need to be replaced?</td><td>" & FaceReplace & "</td></tr>" _
& "</table>"
'Construct the email, pass parameter values, & send the email
With Msg
.To = "test#test.com"
.Subject = "Scrap Face Incident Report"
.HTMLBody = HTMLContent
.Display
'.Send
End With
'MAY NEED WORK
'Make sure the generated email is the active window
App.ActiveWindow.WindowState = olMaximized
'Application.Windows("Scrap Face Incident Report - Message (HTML)").Activate
'Create entry in scrap report
Dim ScrapReportFile As String
ScrapReportFile = "\\jacksonville-dc\common\SOP's for JV\WIP\Jonathan\JG - How to Replace Scrapped Faces\Scrap List (Faces).xlsx"
'File exists
If Dir(ScrapReportFile) <> "" Then
Dim ObjExcel As Object, ObjWb As Object, ObjWorksheet As Object
Set ObjExcel = CreateObject("EXCEL.APPLICATION")
Set ObjWb = ObjExcel.Workbooks.Open(ScrapReportFile)
ObjExcel.Visible = True
With ObjWb.Worksheets(3)
Dim lastrow As Long: lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
MsgBox (lastrow)
End With
'ObjWb.Worksheets(1).Range("A1") = "SOP Title: " & SOPTitle
'ObjWb.Worksheets(1).Range("F1") = "Date: " & Format(Now, "MM/dd/yyyy")
'ObjWb.Save
'ObjWb.Close
End If
'File does not exist; throw error
End Sub
On this section of code:
With ObjWb.Worksheets(3)
Dim lastrow As Long: lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
MsgBox (lastrow)
End With
I am trying to send the data gathered from the form and create a new row at the bottom of the sheet and then insert the data into specified columns. When I am doing the .Cells(.Rows.Count...etc I am getting an error.
Run-time error: '424' Object Required
Word doesn't know what xlUp is, because that is from the Excel object model.
Add the following line:
Const xlUp as Long = -4162
as per the documentation of xlUps corresponding value.

VBA reference sheetname in excel

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

On Click Command Button Macro

I'm trying to create a macro for a command button that when clicked, will get the job number from that row and look for a file for that job. If it does not exist I want it to copy from a template and save with a new name, otherwise just open the file.
However, I cannot seem to work out how to get hold of the information for the command button that calls the macro. This is what I have so far:
Public Function ShapeExists(OnSheet As Object, Name As String) As Boolean
On Error GoTo ErrShapeExists
If Not OnSheet.Shapes(Name) Is Nothing Then
ShapeExists = True
End If
ErrShapeExists:
Exit Function
End Function
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim buttonName As String
buttonName = (Target.Row - 1)
If Not ShapeExists(ActiveSheet, buttonName) Then
If Range("O" & Target.Row).Value = "" And Target.Column <= 14 And Target.Row > 1 Then
ActiveSheet.Buttons.Add(910.5, Range("O" & Target.Row).Top, 80, 20).Select
Selection.Name = buttonName
Selection.OnAction = "Sheet1.JobButton"
ActiveSheet.Shapes(buttonName).Select
Selection.Characters.Text = "Open Job"
End If
End If
End Sub
Private Sub JobButton()
Dim newText As String
ActiveSheet.Shapes(Application.Caller).Select
If Range("N" & Selection.TopLeftCell.Row).Value <> "" Then
newText = "Job " & Range("N" & Selection.TopLeftCell.Row).Value
Dim checkFilename As String
Dim check As String
check = "N" & Selection.TopLeftCell.Row
checkFilename = newText & ".xlsm"
If Dir(checkFilename) <> "" Then
Workbooks.Open (newText)
Else
Dim SrcBook As Workbook
Set SrcBook = ThisWorkbook
Dim NewBook As Workbook
NewBook = Workbooks.Open("Job Template.xlsm")
SrcBook.Worksheets(1).Range("D" & Selection.TopLeftCell.Row).Copy
NewBook.Worksheets(2).Range("B15").PasteSpecial
With NewBook
.Title = newText
.Subject = newText
.SaveAs Filename:=newText
End With
End If
Else
ErrMsg:
MsgBox ("Job Should always have a number."), , "NO JOB NUMBER"
End If
End Sub
As you can see I am currently trying ActiveSheet.Shapes(Application.Caller).Select, this is causing a "Run-time error '13': Type mismatch".
Any help would be much appreciated, thank you!
Right-click the button --> View Code --> put your JobButton code here

Resources