On Click Command Button Macro - excel

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

Related

compare input text to cell and get row in external document

Form 1
I am getting the code to wire to the database file but the check if the value from text box 2 is already in column B throw a message and exit is not working Also if the database is open I am not getting an error it just freezes.
Form 2
I am getting the spinning wheel. It is how it is supposed to work is if textbox1 value is already in column B add time data to column F of that row if it is textbox 1 value is not found in B throw a massage
Any help is appreciated
FORM 1 CODE
Private Sub CommandButton1_Click()
'check to see is all data is filled in
If TextBox1.Value = "" Or TextBox2.Value = "" Or _
TextBox3.Value = "" Or TextBox4.Value = "" Or TextBox5.Value = "" Then
MsgBox "YOU DID NOT FILL IN ALL THE INFO."
Exit Sub
End If
Call Submit_Data
Call resetForm
Unload Me
End Sub
Sub resetForm()
TextBox1.Value = ""
TextBox2.Value = ""
TextBox3.Value = ""
TextBox4.Value = ""
TextBox5.Value = ""
UserForm1.TextBox1.SetFocus
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub UserForm_Click()
End Sub
Sub Submit_Data()
Application.ScreenUpdating = False
Dim App As New Excel.Application
Dim wBook As Excel.Workbook
Dim FileName As String
Dim iRow As Long
FileName = ThisWorkbook.Path & "\test.xlsm"
'Check File Exist or Not
'If Dir(FileName) = "" Then
'MsgBox "Database File is missing. Unable to proceed.", vbOKOnly vbCritical, "Error"
'Exit Sub
'End If
Set wBook = App.Workbooks.Open(FileName)
App.Visible = False
If wBook.ReadOnly = True Then
MsgBox "Database is in use. Please try after sometimes.", vbookonly + vbCritical, "error"
Exit Sub
End If
'Transfer the Data
id = TextBox2.Value
With wBook.Sheets("test")
Set ws = wBook.Sheets("test")
m = Application.Match(id, ws.Columns("B"), 0) 'try to match an existing row
If IsError(m) Then 'no match?
iRow = .Range("A" & Application.Rows.Count).End(xlUp).Row + 1
.Range("A" & iRow).Value = TextBox1.Value 'Cell
.Range("B" & iRow).Value = TextBox2.Value 'workorder number
.Range("C" & iRow).Value = TextBox3.Value 'product number
.Range("D" & iRow).Value = TextBox4.Value 'Work order quanity
.Range("E" & iRow).Value = Date 'date
.Range("F" & iRow).Value = Time 'time
.Range("M" & iRow).Value = TextBox5.Value 'crew size
Else
MsgBox "JOB ALREADY CLOCKED IN!"
Exit Sub
End If
End With
wBook.Close Savechanges:=True
App.Quit
Set App = Nothing
'Reset the form
Call resetForm
Application.ScreenUpdating = True
MsgBox "Data submitted successfully!"
End Sub
FORM 2 CODE
Private Sub CommandButton1_Click()
'check to see is all data is filled in
If TextBox1.Value = "" Then
MsgBox "YOU DID NOT ENTER WO."
Exit Sub
End If
Call Submit_Data
Call resetForm
Unload Me
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Sub Submit_Data()
Application.ScreenUpdating = False
Dim App As New Excel.Application
Dim wBook As Excel.Workbook
Dim FileName As String
Dim iRow As Long
FileName = ThisWorkbook.Path & "\Database.xlsm"
'Check File Exist or Not
'If Dir(FileName) = "" Then
'MsgBox "Database File is missing. Unable to proceed.", vbOKOnly vbCritical, "Error"
'Exit Sub
'End If
Set wBook = App.Workbooks.Open(FileName)
App.Visible = False
If wBook.ReadOnly = True Then
MsgBox "Database is in use. Please try after sometimes.", vbookonly + vbCritical, "error"
Exit Sub
End If
'Transfer the Data
id = TextBox1.Value
With wBook.Sheets("Database")
m = Application.Match(id, ("B"), 0) 'try to match an existing row
If IsError(m) Then 'no match?
MsgBox "NEVER CLOCKED IN"
Exit Sub
End If
With ws.Rows(m)
.Columns("F").Value = Time
wBook.Close Savechanges:=True
App.Quit
Set App = Nothing
'Reset the form
Call resetForm
Application.ScreenUpdating = True
MsgBox "Data submitted successfully!"
End With
End With
End Sub
Sub resetForm()
TextBox1.Value = ""
UserForm1.TextBox1.SetFocus
End Sub
Private Sub UserForm_Click()
End Sub
If the ID values on your "database" sheet are numeric, you need to use a numeric input for Match(), so:
'Transfer the Data
id = CLng(TextBox2.Value) '<<< assuming the value is numeric: may want to add a check...
With wBook.Sheets("test")
Set ws = wBook.Sheets("test")
m = Application.Match(id, ws.Columns("B"), 0) 'try to match an existing row
If IsError(m) Then 'no match?
iRow = .Range("A" & Application.Rows.Count).End(xlUp).Row + 1
'etc
'etc
You don't need a separate instance of Excel to save the record - it's better to just open the file in the existing instance.
Also - if you're planning on not closing the file immediately after populating the data row, you need to check to see if it's already open when you perform the next save: opening a file which is already open can give unexpected results. See https://stackoverflow.com/a/56262538/478884

Hyperlink link of the Image from userform added wont open

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

object required run time error '424'

i am getting object required run time error in below code at line , i checked sheet names they are correct but still showing same error Sheet1.Range("A1").Value = Date & " " & Time
Private Sub CommandButton1_Click()
Dim username As String
Dim password As String
username = TextBox1.Text
password = TextBox2.Text
Dim info
info = IsWorkBookOpen("D:\TMS_Project\username-password.xlsx")
If info = False Then
Workbooks.Open ("D:\TMS_Project\username-password.xlsx")
End If
Dim x As Integer
x = 2
Do While Cells(x, 1).Value <> ""
If Cells(x, 1).Value = username And Cells(x, 2).Value = password Then
MsgBox "Welcome!"
Sheet1.Range("A1").Value = Date & " " & Time
Selection.NumberFormat = "m/d/yyyy h:mm AM/PM"
UserForm1.Hide
ActiveWorkbook.Close True
End
Else
x = x + 1
End If
Loop
MsgBox "Please check your username or password!"
ActiveWorkbook.Close True
TextBox1.Text = ""
TextBox2.Text = ""
TextBox1.SetFocus
End Sub
When you use Sheet1.Range("A1").Value, Sheet1 is actually the Worksheet.CodeName property, read here on MSDN.
While I think you meant to use the worksheet, which name is "Sheet1", then you need to use Worksheets("Sheet1").Range("A1").Value.
If you would have defined and set your Worksheet object, you would have been able to track it.
I am using the piece of code below, to verify that no one has changed my sheet's name (or deleted it).
Option Explicit
' list of worksheet names inside Workbook - easy to modify here later
Const ShtName As String = "Sheet1"
'====================================================================
Sub VerifySheetObject()
Dim Sht As Worksheet
On Error Resume Next
Set Sht = ThisWorkbook.Worksheets(ShtName)
On Error GoTo 0
If Sht Is Nothing Then ' in case someone renamed the Sheet (or it doesn't exist)
MsgBox "Sheet has been renamed, it should be " & Chr(34) & ShtName & Chr(34), vbCritical
Exit Sub
End If
' your line here
Sht.Range("A1").Value = Date & " " & Time
End Sub
To use Variables for your Sheets use:
Dim sht as Worksheet
Set sht = Worksheets("Name")
If you are refering a lot to worksheets its a must to use, but also makes it much easier to change later on.

Global variable in userforms does not work

I am creating userforms. Userforms are pretty connected to each other - use informations one from another. So... I thought about creating few global variables to make my life easier:
Public nazwa_arkusza As String
Public skoroszyt As Workbooks
Public arkusz As Worksheet
They are wrote in Useform Klient_kraj. Edytuj is Combobox within Klient_kraj Userform. I want to execute arkusz variable in different userform, but I get run-time error: "Object does not support this method"
Private Sub but_next_Click()
Dim Faktura As Range, faktury_range As Range
Dim LastRow As Integer
LastRow = Klient_kraj.skoroszyt.arkusz.Cells(Rows.Count, 1).End(xlUp).Row 'error line
Set faktury_range = skoroszyt.Range("A1:A" & LastRow)
(...)
end sub
.
Private Sub edytuj_Click()
Dim nazwa As String
nazwa_arkusza = kraj.List(kraj.ListIndex, 1) & " " & Mid(okres1.Value, 4, 2) & Mid(okres2.Value, 3, 3)
nazwa = "C:\1\" & klient.Text & ".xlsx"
'Jeżeli kraj nie wybrany = msgbox
If kraj.Value = "" Then
MsgBox ("Nie wybrałeś kraju")
Exit Sub:
Else
If okres1.Value = "" Or okres2.Value = "" Then
MsgBox ("Nie wybrałeś okresu rozliczeniowego")
Exit Sub:
End If
End If
'Jeżeli nie ma pliku - utwórz nowy
If Dir(nazwa) = "" Then
Workbooks.Add(1).SaveAs Filename:="C:\1\" & klient.Text, FileFormat:=51
Worksheets(1).Name = nazwa_arkusza
Else
'Jeżeli nie jest otwarty - otwórz
On Error GoTo niema_pliku:
If GetObject(, "Excel.Application").Workbooks(Klient_kraj.klient.Text & ".xlsx") Is Nothing Then
Workbooks.Open Filename:="C:\1\" & klient.Text & ".xlsx"
Else
Workbooks(Klient_kraj.klient.Text).Activate
End If
End If
Set skoroszyt = Workbooks(Klient_kraj.klient.Text & ".xlsx")
'Jeżeli arkusz nie istnieje - utwórz; istnieje - aktywuj
On Error GoTo niema_arkusza:
If skoroszyt.Worksheets(nazwa_arkusza).Name = "" Then
Else
skoroszyt.Worksheets(nazwa_arkusza).Activate
End If
On Error GoTo 0
Set arkusz = Sheets(nazwa_arkusza)
Application.Windows(klient.Text & ".xlsx").Visible = False
Faktura.Show
niema_pliku:
If Err.Number = 9 Then
Resume Next
End If
niema_arkusza:
If Err.Number = 9 Then
skoroszyt.Worksheets.Add.Name = nazwa_arkusza
skoroszyt.Worksheets(nazwa_arkusza).Activate
Resume Next
End If
End Sub
This variable will also be used in different userform.
What am I doing wrong?

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

Resources