Easier way to create multiple macros

[scotball]

I am creating an inventory/stock control sheet for a client.

They have 100-130 items they want to run a stick control on. Then once they have the starting numbers they want two buttons on each row, one to increase the Qty and the other to decrease the Qty by 1.

So far I have created the first Increase and Decrease macros, then copy pasted, adjusted for the next row. Then I have added 2 buttons from the control box and assigned the appropriate macro to each box. Tested and each button works as intended.

My question is this... is there a quicker way to do this so that I don't have to replicate the below code over 100 times? I am going to have to create the buttons and assign the macros but I was hoping there was an easier way... eg... If I click on the quantity, for example cell B34, the increase button is then assigned to B34 so if I click it, the value in B34 increases by 1, without impacting the other numbers?

So, I'd have 100-130 rows. A= Item Desc, B=Qty (starting at row 3) - two buttons, one for increase, one for decrease. I click into B34, click Increase button and the Qty in B34 increases by 1.

The code I have for the first 2 rows is:

Sub CellB3incr()'
' Increase contents of cell by 1 per click
'
    Range("B3").Select
    Range("B3").Value = Range("B3").Value + 1
End Sub


Sub CellB3decr()
'
' Decrease contents of cell by 1 per click
'


    Range("B3").Select
    Range("B3").Value = Range("B3").Value - 1
End Sub


Sub CellB4incr()
'
' Increase contents of cell by 1 per click
'
    Range("B4").Select
    Range("B4").Value = Range("B4").Value + 1
End Sub


Sub CellB4decr()
'
' Decrease contents of cell by 1 per click
'


    Range("B4").Select
    Range("B4").Value = Range("B4").Value - 1
End Sub

 

[Michael M]

Maybe these

Sub CellB3incr() '
Dim r As Long
For r = 3 To 133
    Range("B" & r).Value = Range("B" & r).Value + 1
Next r
End Sub


Sub CellB3decr()
Dim r As Long
For r = 3 To 133
    Range("B" & r).Value = Range("B" & r).Value - 1
Next r
End Sub

 

[scotball]

Thanks Michael, however that code increments every cell in Col B.

What I need is for this to only increment the ACTIVE cell.. so if I select B34 and then click on Increase, B34 (Qty) increases by 1 (and vice versa for Decrease)

 

[Michael M]

Aaah, sorry....misunderstood

Sub CellB3incr() '
activecell.Value = activecell.Value + 1
End Sub


Sub CellB3decr()
activecell.Value = activecell.Value - 1
End Sub

 

[Logit]

.
Take a different approach.

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VB7 Then
Private Declare PtrSafe Function FindWindow Lib "user32" _
        Alias "FindWindowA" ( _
        ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long


Private Declare PtrSafe Function GetWindowLong Lib "user32" _
        Alias "GetWindowLongA" ( _
        ByVal hWnd As Long, _
        ByVal nIndex As Long) As Long


Private Declare PtrSafe Function SetWindowLong Lib "user32" _
        Alias "SetWindowLongA" ( _
        ByVal hWnd As Long, _
        ByVal nIndex As Long, _
        ByVal dwNewLong As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
Private Declare Function FindWindow Lib "user32" _
        Alias "FindWindowA" ( _
        ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long


Private Declare Function GetWindowLong Lib "user32" _
        Alias "GetWindowLongA" ( _
        ByVal hWnd As Long, _
        ByVal nIndex As Long) As Long


Private Declare Function SetWindowLong Lib "user32" _
        Alias "SetWindowLongA" ( _
        ByVal hWnd As Long, _
        ByVal nIndex As Long, _
        ByVal dwNewLong As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
Const GWL_STYLE = -16
Const WS_SYSMENU = &H80000


Private Sub CommandButton1_Click()
'MsgBox "You clicked !!!", vbExclamation, "Active Cell Address: " & ActiveCell.Address
Selection.Value = Selection.Value + 1
End Sub


Private Sub CommandButton2_Click()
Selection.Value = Selection.Value - 1
'Unload Me
End Sub


Private Sub UserForm_Initialize()
Dim hWnd As Long, lStyle As Long
If Val(Application.Version) >= 9 Then
    hWnd = FindWindow("ThunderDFrame", Me.Caption)
Else
    hWnd = FindWindow("ThunderXFrame", Me.Caption)
End If
lStyle = GetWindowLong(hWnd, GWL_STYLE)
SetWindowLong hWnd, GWL_STYLE, (lStyle And Not WS_SYSMENU)
End Sub

Download workbook : https://www.amazon.com/clouddrive/share/isB82iDKZW3l0SXFEuUxSnFSwXvn2EyD8pnsZ8UCxZO

 

[scotball]

lol... it was my terrible way of describing it... In the interim I had a lightbulb moment and did the exact same code as you lol... thank you for your help though

 

[Michael M]

Same code as who....???

 

[offthelip]

You can do this without using vba at all excpet to add the buttons. this code will add spinners to each row to allow you to increment and decrement cells:

 Sub addspin()
For i = 1 To 10
Cells(i, 5).Select
Col = ActiveCell.Address
Xloc = ActiveCell.Top
Yloc = ActiveCell.Left
CelHeight = ActiveCell.Height


'
ActiveSheet.Spinners.Add(Yloc, Xloc, 9, CelHeight).Select
With Selection
.Min = 0
.Max = 30000
.SmallChange = 1
.LinkedCell = Col
.Display3DShading = True
.PrintObject = False
End With
Next i
 End Sub

 

[Eric W]

Here's another possibility. You don't need any buttons at all. You can add the Add 1/Subtract 1 options to the right-click context menu. So all they have to do is right click on the Quantity cell, then select "Add 1" or "Subtract 1".

To try that, put these macros on the ThisWorkbook module:

Private Sub Workbook_Deactivate()
    On Error Resume Next
        With Application
            .CommandBars("Cell").Controls("Add 1").Delete
            .CommandBars("Cell").Controls("Subtract 1").Delete
        End With
    On Error GoTo 0
End Sub
 
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    Dim cmdBtn As CommandBarButton
    On Error Resume Next
        With Application
            .CommandBars("Cell").Controls("Add 1").Delete
            .CommandBars("Cell").Controls("Subtract 1").Delete
        End With
        If ActiveSheet.Name <> "Sheet1" Then Exit Sub
        If Target.Column <> 2 Then Exit Sub
        
        With Application.CommandBars("Cell").Controls.Add(Temporary:=True)
           .Caption = "Add 1"
           .Style = msoButtonCaption
           .OnAction = "Add1"
        End With
        With Application.CommandBars("Cell").Controls.Add(Temporary:=True)
           .Caption = "Subtract 1"
           .Style = msoButtonCaption
           .OnAction = "Subtract1"
        End With


    On Error GoTo 0
End Sub

The lines in red are to restrict the new menu items to a particular sheet and column. You can get more specific if necessary. Then add these macros to a standard module:

Public Function Add1()
    ActiveCell = ActiveCell + 1
End Function
Public Function Subtract1()
    ActiveCell = ActiveCell - 1
End Function

 

[Fazza]

another way

borrow the next two columns. one coloured red for subtractions, other coloured green for additions

then on double click in a cell, the count adjusts - down 1 if it was the red cell, up 1 if it was the green cell.

could also add a text in the next column, along lines, "last change was ±1 by username at 11:15 am 15-Dec-18"
or even create a log of changes on another worksheet. or a text file