CODEWITHSUNDEEP
excelvba
henryprescott
henryprescott

Reputation: 483

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!

Upvotes: 0

Views: 1733

Answers (1)

Charles Williams
Charles Williams

Reputation: 23550

Right-click the button --> View Code --> put your JobButton code here

Upvotes: 1

Related Questions