Why does the userform (a barcode) not show up with this code (only timer is running):
Sub Barcode_Show()
'show barcode form
On Error GoTo Errorhandler
Application.OnTime Now, "Barcode_Close"
DoEvents
Load form_Barcode
With form_Barcode
.Barcode128 = rngTarget.Value
**If ActiveSheet.CodeName = wsPastorer Then
.BarcodeLabel = "P" & TankCell.Value & " - " & ProduktCell.Value
Else
.BarcodeLabel = "T" & TankCell.Value & " - " & ProduktCell.Value
End If**
.Show
End With
Exit Sub
Errorhandler:
Call Barcode_Close
End Sub
When I change it to
DoEvents
Load form_Barcode
With form_Barcode
.Barcode128 = rngTarget.Value
.BarcodeLabel = "T" & TankCell.Value & " - " & ProduktCell.Value
.Show
End With
it will work.
I tried to have some other code in that place before, and it didn't work either. Why is it not possible and how to write the code so the form will show?
I wanted to add Button to each row against each activities from 11 to 35, button is in column 'K11' while clicking on button macro will automattically add user name and time in cell Q11 and enter text as success in cell N11
I have created below button on row 11.
Sub addDetail()
Sheets("sheet1").Range("Q11").Value = _
Environ("username") & " - " & Format(Now, "mm/dd/yyyy HH:mm:ss")
Range("N11").Value = "Success"
End Sub
do i have to create this code for 25 times to add code to each button in each row or there is any other method?
Consider using a loop:
Sub addDetail()
Dim roww As Long
With Sheets("sheet1")
For roww = 11 To 35
.Range("Q" & roww).Value = Environ("username") & " - " & Format(Now, "mm/dd/yyyy HH:mm:ss")
.Range("N" & roww).Value = "Success"
Next roww
End With
End Sub
In a similar fashion, you can create a button maker routine that uses a loop to place buttons on rows 11 through 35.
EDIT#1:
I put a small Forms button on row#11 and assigned this macro to it:
Sub Button1_Click()
Dim s As Shape
shapename = Application.Caller
Set s = ActiveSheet.Shapes(shapename)
Call addDetail(s.TopLeftCell.Row)
End Sub
The macro can be used for all the buttons.
The macro determines the row it is on and calls the addDetails() sub with the correct row information. We must modify addDetails() to accept the row:
Sub addDetail(roww As Long)
With Sheets("sheet1")
.Range("Q" & roww).Value = Environ("username") & " - " & Format(Now, "mm/dd/yyyy HH:mm:ss")
.Range("N" & roww).Value = "Success"
End With
End Sub
Application Caller feat. Buttons
Option Explicit
Sub addDetail_Click()
On Error GoTo CleanExit
Dim btnRow As Long
With ActiveSheet
btnRow = .Shapes(Application.Caller).TopLeftCell.Row
.Cells(btnRow, "Q").Value = _
Environ("username") & " - " & Format(Now, "mm/dd/yyyy HH:mm:ss")
.Cells(btnRow, "N").Value = "Success"
End With
CleanExit:
End Sub
Having 25 buttons next to each other is probably not the best approach. If you need this, each Shape has TopLeftCell attribute, so you can use the very same code for all 25 buttons and replace the row in the two ranges with this attribute.
If you would be happy with one button only, what about creating a set-up like this
So that you can change the row that you want to edit and just need one button?
Sub addDetail()
dim rowA as string
rowA = range("B2").value
Sheets("sheet1").Range("Q" & rowA).Value = _
Environ("username") & " - " & Format(Now, "mm/dd/yyyy HH:mm:ss")
Range("N" & rowA).Value = "Success"
End Sub
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 have the following code that works fine for normal worksheets, but when I try to right click over a table the macro does not appear.
I have tried the below but getting "Object Required" error message on the first line:
With ContextMenuListRange.Controls.Add(Type:=msoControlButton, before:=2)
.OnAction = "'" & ThisWorkbook.Name & "'!" & "macro"
.Caption = "macro"
.Tag = "My_Cell_Control_Tag"
End With
The below works fine with a normal worksheet.
With ContextMenu.Controls.Add(Type:=msoControlButton, before:=2)
.OnAction = "'" & ThisWorkbook.Name & "'!" & "macro"
.Caption = "macro"
.Tag = "My_Cell_Control_Tag"
End With
How do I get to appear when right clicking over a table?
Try adding your button to the List Range Popup shortcut menu...
With Application.CommandBars("List Range Popup").Controls.Add(Type:=msoControlButton, before:=2)
.OnAction = "'" & ThisWorkbook.Name & "'!" & "macro"
.Caption = "macro"
.Tag = "My_Cell_Control_Tag"
End With
You can use the following macro to generate a list of all shortcut menus...
Sub ShowShortcutMenuNames()
Dim Row As Long
Dim cbar As CommandBar
Row = 1
For Each cbar In Application.CommandBars
If cbar.Type = 2 Then 'msoBarTypePopUp
Cells(Row, 1) = cbar.Index
Cells(Row, 2) = cbar.Name
Row = Row + 1
End If
Next cbar
End Sub
Hope this helps!
Reference
I am trying to add code (a subroutine call) to a procedure within Sheet1 by finding the line number of the procedure's statement within sheet1 in VBE then adding the code to the next line over. The following code attempts to achieve this.
' This will search for and modify the appropriate Node#button_Click() subroutine
With ActiveWorkbook.VBProject.VBComponents("Sheet1").CodeModule
ProcLineNum = .ProcStartLine("Node" & NumNodes & "Button" & "_Click", 0)
.InsertLines ProcLineNum + 1, "load_node_form(" & DQUOTE & "Node " & NumNodes & DQUOTE & ")"
End With
The entire subroutine is the following:
Public Sub Node_Button_Duplication()
'
'Com: Copies and pastes Node 1's button to the appropriate column
Dim shp As Shape
Dim code As String
Dim ProcLineNum As Long
Const DQUOTE = """"
' Copy Node 1 button and paste in appropriate location
ActiveSheet.Shapes("CommandButton1").Select
Selection.Copy
Cells(5, 10 + 7 * (NumNodes - 1) - 1).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 47.25
Selection.ShapeRange.IncrementTop -13.5
Set shp = ActiveSheet.Shapes(Selection.Name)
With shp.OLEFormat.Object
.Object.Caption = "Node" & Str(NumNodes)
.Name = "Node" & NumNodes & "Button"
End With
' This will search for and modify the appropriate Node#button_Click() subroutine
With ActiveWorkbook.VBProject.VBComponents("Sheet1").CodeModule
ProcLineNum = .ProcStartLine("Node" & NumNodes & "Button" & "_Click", 0)
.InsertLines ProcLineNum + 1, "load_node_form(" & DQUOTE & "Node " & NumNodes & DQUOTE & ")"
End With
End Sub
The subroutine will copy and paste a button ("CommandButton1"), rename it, then attempts to assign a subroutine call. The problem in finding the procedure is that once the new button is created, the "CommandButton#_Click() procedure doesn't show up in VBE until I go and select it from the editor, thus causing an error when my code tries to search for that procedure.
Is this what you are trying?
Option Explicit
Public Sub Node_Button_Duplication()
Dim shp As Shape
Dim code As String
Dim ProcLineNum As Long, NumNodes As Long
Const DQUOTE = """"
ActiveSheet.Shapes("CommandButton1").Select
Selection.Copy
Cells(5, 10 + 7 * (NumNodes - 1) - 1).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 47.25
Selection.ShapeRange.IncrementTop -13.5
Set shp = ActiveSheet.Shapes(Selection.Name)
With shp.OLEFormat.Object
.Object.Caption = "Node" & Str(NumNodes)
.Name = "Node" & NumNodes & "Button"
End With
With ActiveWorkbook.VBProject.VBComponents( _
ActiveWorkbook.Worksheets("Sheet1").CodeName).CodeModule
.InsertLines Line:=.CreateEventProc("Click", "Node" & NumNodes & "Button") + 1, _
String:=vbCrLf & _
"load_node_form(" & DQUOTE & "Node " & NumNodes & DQUOTE & ")"
End With
End Sub