I am trying to create a counter that displays how many times a macro enabled button is clicked. I'm having trouble identifying the active cell associated with macro enabled button. It will be anywhere from cell A9 through A50 (I will have multiple macro buttons that will apply on the page).
Code needs to look at cell directly to the right of the active cell and add 1 to that number when a button is pushed. I'm new to VBA and not having success at applying the suggested questions to my scenario.
Here is how the button is being placed onto the sheet if it is helpful in resolving the problem.
Sub VBA_Input_Idea_inputbox()
Dim MyInp As String
Dim NextRow As Long
Dim Counter As Long
Dim btn As Button
Dim t As Range
Counter = Counter + 1
MyInp = VBA.Interaction.InputBox("Please input idea", "LEARNING REQUEST")
If MyInp = "" Then Exit Sub
NextRow = Cells(Rows.Count, 3).End(xlUp).row + 1
Range("C" & NextRow).Value = Excel.WorksheetFunction.Proper(MyInp)
Set t = ActiveSheet.Range("A" & NextRow)
Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, t.Width, t.Height)
With btn
.OnAction = "VBA_Love_It_msgbox3"
.Caption = "Vote for this Idea!"
.Name = "btn" & "Love This"
End With
Range("B" & NextRow) = Counter
End Sub
In the macro attached to the button, Application.Caller will give you the name of the button/shape calling the code:
Sub VBA_Love_It_msgbox3()
With ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, 1)
.Value = .Value + 1
End With
End Sub
EDIT: for this to work you need to ensure your buttons all have different names.
Related
I have this problem. I've only been doing VBA for about a week. I have a workbook where I created a button that copies a certain range in a row and pastes it into a table on another sheet. My problem is this: do I need to create a module for each button, or can I somehow simplify the code to create the same buttons for each row on the first sheet?
Sub SelectRangea()
Sheets("Tournaments").Select
Range("B4:G4").Select
Application.CutCopyMode = False
Selection.Copy
With Sheets("Results")
lst = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & lst).PasteSpecial xlPasteColumnWidths
.Range("A" & lst).PasteSpecial xlPasteValues
End With
End Sub
You'll need to adjust the code accordingly but this will add a set of buttons for you as well as tell you the cell that the button was pressed from ...
Public Sub AddButtons()
Dim lngRow As Long, rngCell As Range, objButton As Shape
For lngRow = 1 To 10
Set rngCell = Sheet1.Cells(lngRow, 1)
Set objButton = Sheet1.Shapes.AddFormControl(xlButtonControl, rngCell.Left, rngCell.Top, rngCell.Width, rngCell.Height)
objButton.OnAction = "ButtonPushAction"
Next
End Sub
Public Sub ButtonPushAction()
Dim objCaller As Shape
Set objCaller = Sheet1.Shapes(Application.Caller)
MsgBox "Top Cell = " & objCaller.TopLeftCell.Address & vbCrLf & _
"Row = " & objCaller.TopLeftCell.Cells(1, 1).Row & vbCrLf & _
"Column = " & objCaller.TopLeftCell.Cells(1, 1).Column, vbInformation, "Button Push"
End Sub
Do I need to create a module for each button?
We only need to create one module containing the macros needed by the buttons and we can use the same macro for all the buttons.
Can I somehow simplify the code to create the same buttons for each row on the first sheet?
All the buttons should be identical, except their names. They can be copies of each other.
I assume we want to copy the row clicked. So I changed SelectRangea:
' Copy the code below to a standard module
Public Sub SelectRangea(RowNumber As Integer)
' Copy the row clicked
Sheets("Tournaments").Select
Range("B" & RowNumber & ":G" & RowNumber).Select
Application.CutCopyMode = False
Selection.Copy
' Paste the row clocked
With Sheets("Results")
lst = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & lst).PasteSpecial xlPasteColumnWidths
.Range("A" & lst).PasteSpecial xlPasteValues
End With
End Sub
And here is the click handler for the buttons:
' Copy the code below to a standard module
Public Sub MyButton_Click()
Dim Btn As Object
Dim RowNumber As Integer
'Set Btn = ActiveSheet.Buttons(Application.Caller) ' either this
Set Btn = ActiveSheet.Shapes(Application.Caller) ' or this
With Btn.TopLeftCell
RowNumber = .Row
End With
SelectRangea RowNumber
End Sub
Automatically create the buttons
We could create a macro that creates the buttons, if they don't exist, using Sheet.Shapes.AddShape and sets the .OnAction of them to MyButton_Click:
' Copy the code below to a standard module.
' Create buttons on a sheet.
' Sht : The sheet to create buttons on
' RowNumber : Create buttons from RowNumber and down.
' ColNumber : The column the button is created in.
' ColNumberSrc: The column used to determine the number of rows.
Public Sub AddButtons(Sht As WorkSheet,
RowNumber As Integer,
ColNumber As Integer,
ColNumberSrc As Integer)
Dim MyLeft As Double
Dim MyTop As Double
Dim Rng As Range
Dim Shp As Shape
Dim NumRows As Integer
NumRows = Sht.Range.Cells(Sht.Rows.Count, ColNumberSrc).End(xlUp).Row
If NumRows < RowNumber Then Exit Sub
For Idx = RowNumber To NumRows
Set Rng = Sht.Range.Cells(Idx, ColNumber)
MyLeft = Rng.Left
MyTop = Rng.Top
' We could let the size of the button's we create be the same size as the cell.
Set Shp = Sht.Shapes.AddShape(msoShapeRectangle, MyLeft, MyTop, 100, 22)
Shp.Name = "Btn" & Sht.Index & "_" & Idx
Shp.TextFrame.Characters.Text = "Clickme"
Shp.OnAction = "MyButton_Click"
Next Idx
End Sub
Don't use buttons
We could remove the buttons and use double-click instead. This will copy the double-clicked row:
' Copy the three lines to the corresponding function in your sheet module.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim RowNumber As Integer
RowNumber = Target.Row
SelectRangea RowNumber
End Sub
Don't confuse the user
We should avoid the use of Copy and Select, as it can worsen the user experience. We should only use them when the user expects us to use them. Refactor the code to avoid using them:
' Copy the code below to a standard module
Public Sub SelectRangea(ByVal RowNumber As Integer)
Dim Sht As WorkSheet
Dim Rng As Range
Dim Dat As Variant
' Copy the row clicked
Set Sht = Sheets("Tournaments")
Set Rng = Sht.Range("B" & RowNumber & ":G" & RowNumber)
Dat = Rng
' Paste the row
Set Sht = Sheets("Results")
RowNumber = Sht.Range("A" & Sht.Rows.Count).End(xlUp).Row + 1
Set Rng = Sht.Range("B" & RowNumber & ":G" & RowNumber)
Rng = Dat
' Fix column widths
Sht.UsedRange.Columns.AutoFit
End Sub
See also
how to add a shape at a specific cell
how to get the row number of the button clicked.
how to get the row of the cell clicked
NB
I don't have access to an office environment, so I can't test the code at the moment.
I think we can set an option for a shape so it stays in it's cell when cells are resized, added or deleted.
I am trying to create a tool with a userform where the user types a Model in a textbox and selects all the countries where this Model comes from in 10 possible checkboxes.
This information is transferred to "Country" Worksheet through command button.
My code places textbox value in column A and country name from checkbox label in column B.
The problem is that I have more than one country for the same model so I'm getting blank cells without matching Model.
E.g. "Type A" belongs to USA, Brazil, Sweden and Mexico, so I should have "Type A" copied four times along country names instead of just one.
Private sub Transfer()
Dim i As Long
Dim aCol As Range
Dim BS As Worksheet
Set aCol = Worksheets("Country").Range("A:A")
Set BS = Worksheets("Country")
For i = 1 To 10
With Me.Controls("CheckBox" & i)
If .Value Then
aCol.Cells(82, 2).End(xlUp).Offset(1, 0).Value = .Caption
End If
End With
Next i
Dim b As Integer
b = 1
Do Until BS.Range("A" & b).Value = ""
b = b + 1
end sub
With the code you shared and without major changes, I would suggest you to think about writing the info contained in the textbox within the loop of the checkboxes and right after the if. This way you will be adding the textbox text no matter what avoiding the blanks
If .Value Then
aCol.Cells(82, 1).End(xlUp).Offset(1, 0).Value = Me.Controls("TextBox1").Text
aCol.Cells(82, 2).End(xlUp).Offset(1, 0).Value = .Caption
End If
Let me know if that works, below the full code I used to replicate your issue:
Private Sub CommandButton1_Click()
Call Transfer
End Sub
Private Sub Transfer()
Dim i As Long
Dim aCol As Range
Dim BS As Worksheet
Set aCol = Worksheets("Country").Range("A:A")
Set BS = Worksheets("Country")
For i = 1 To 3
With Me.Controls("CheckBox" & i)
If .Value Then
aCol.Cells(82, 1).End(xlUp).Offset(1, 0).Value = Me.Controls("TextBox1").Text
aCol.Cells(82, 2).End(xlUp).Offset(1, 0).Value = .Caption
End If
End With
Next i
End Sub
How the form I did looks in VBA
How the results look like in the file
Trying to create an inputbox that a user can type notes into, those notes will be input onto the same document and simultaneously create a macro enables “thumbs up icon” that will hold a macro that other members can “thumbs up” ideas they want to promote. The code below is causing the button to duplicate itself on the same cell. I need it to instead apply to the next available cell.
Sub VBA_Input_Idea_inputbox()
Dim MyInp As String
Dim NextRow As Long
MyInp = VBA.Interaction.InputBox("Please input idea", "LEARNING
REQUEST")
If MyInp = "" Then Exit Sub
NextRow = Cells(Rows.Count, 3).End(xlUp).Row + 1
Range("C" & NextRow).Value =
Excel.WorksheetFunction.Proper(MyInp)
Range("A" & NextRow).Select
ActiveSheet.Buttons.Add(0.75, 145.5, 42, 24.75).Select
Selection.OnAction = "Addcount"
End Sub
Something like this:
Sub VBA_Input_Idea_inputbox()
Dim MyInp As String
Dim NextRow As Range, btn
MyInp = VBA.Interaction.InputBox("Please input idea", "LEARNING REQUEST ")
If MyInp = "" Then Exit Sub
With ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).EntireRow
.Cells(3).Value = Application.Proper(MyInp)
Set btn = ActiveSheet.Buttons.Add(.Cells(1).Left, .Cells(1).Top, _
.Cells(1).Width, .Cells(1).Height)
btn.OnAction = "Addcount"
End With
End Sub
I have a tool, where I insert multiple small button in multiple column automatically (assume Column C1:C90,E1:E90,G1:G90...), based on some selection criteria. I am using the .Buttons.Add method of the Worksheet class to create the buttons.
I am unable to find correct cell address when I click on a button. E.g. If I click on button in cell C2, It gives C70 cell address, if I Click on E4 it still gives some other cell address. I tried with following code below. Can anyone help me on this?,
Sub Mainscoresheet()
' Mainlineup Macro to add button
Dim b As Object, RowNumber,ColNumber As Integer
Set b = ActiveSheet.Buttons(Application.Caller)
With b.TopLeftCell
RowNumber = .Row
ColNumber = .Col
End With
MsgBox "Row Number " & RowNumber
MsgBox "Row Number " & ColNumber
End Sub
I added below the button add function.
XRow = 7: xCol = 5
Do Until wks.Cells(XRow, 1) = ""
DoEvents
For i = 1 To M_Count
Set Bt = wks.Range(Cells(XRow, xCol), Cells(XRow, xCol))
Set btn = wks.Buttons.Add(Bt.Left + 1, Bt.Top + 1, Bt.Width - 2, Bt.Height - 2)
With btn
.OnAction = "BtnCopy"
.Caption = ">>"
.name = "Note" & Now
End With
xCol = xCol + 2
Next i
xCol = 5
XRow = XRow + 1
Loop
You are trying to identify the button that was clicked with the following line:
Set b = ActiveSheet.Buttons(Application.Caller)
Using Application.Caller in this way relies on each Button having a unique name. However, when you create the buttons you use this code:
With btn
.OnAction = "BtnCopy"
.Caption = ">>"
.name = "Note" & Now
End With
But you use the Now function to add an 'id' to the Button. Using Now means that you may create more than one button with the same name because the code will run quick enough that Now will not increment within the code. Also, if you run the code a few times e.g. create buttons in 3 columns in 3 different runs then each set of buttons may likely have the same name. This will confuse Application.Caller in that it will just return the Button that is the 'first match`.
So you should use a counter to create a unique name for each button. See the code example below that does this for sample set of 10 Buttons:
Option Explicit
Sub CallButton()
Dim btn As Object
Dim lngRow As Long, lngCol As Long
Set btn = ActiveSheet.Buttons(Application.Caller)
With btn.TopLeftCell
lngRow = .Row
lngCol = .Column
End With
MsgBox "Button name " & btn.Name
MsgBox "Row Number " & lngRow
MsgBox "Col Number " & lngCol
End Sub
Sub Make10Buttons()
Dim ws As Worksheet
Dim lng As Long
Dim rng As Range
Dim btn As Object
Set ws = ThisWorkbook.Worksheets("Sheet1")
For lng = 1 To 10
Set rng = ws.Cells(lng + 1, 2)
Set btn = ws.Buttons.Add(rng.Left, rng.Top, rng.Width, rng.Height)
With btn
.OnAction = "CallButton"
.Caption = ">>"
.Name = "Note" & lng '<--- need a unique ID for each button
End With
Next lng
End Sub
You can adapt the sample to work with your code by using XRow and xCol to create an unique suffix to append to each of your buttons.
I want to assign a value in column like serial number via click button. I already a make one code but its without button. I want to add button also.
Option Base 1
Function Check()
Dim i As Integer
Dim startCell As Range
Dim firstNonEmptyCell As Range
Set startCell = Range("G2")
If VBA.IsEmpty(startCell.Value) Then
MsgBox "No data in this column"
Else
Range("A2") = 1
Range("A2").Select
Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
Step:=1, Stop:=400, Trend:=False
End If
End Function
Insert a Form button via Insert in the Developer Toolbar.
Paste the below code in a module and then right click on the button and click on assign Macro.
Select Button1_Click in the Assign Macro dialog box and you are done.
Code
Option Explicit
Sub Button1_Click()
Dim ws As Worksheet
Dim LRow As Long, i As Long
'~~> Change this to the relevant worsheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find Last Row in Col G which has data
LRow = .Range("G" & .Rows.Count).End(xlUp).Row
If LRow = 1 Then
MsgBox "No data in column G"
Else
For i = 2 To LRow
.Range("A" & i).Value = i - 1
Next i
End If
End With
End Sub