I am creating a spreadsheet for my budget, where some cells keep track of my expenses in a month in a particular field. For example, a cell might keep track of all my expenses on food in June 2023. Such cells start with a "=" sign followed by a mathematical expression with numbers, plus or minus signs, and parentheses. For example: "=345+86-72+782".
I am trying to write VBA code for a macro that detects all such cells in the active sheet and assigns ActiveX command buttons to each of these cells which on clicking open an input box where I can type in a new expense (like "+31") and it will get added to the cell.
I am running into several errors, can someone help?
Sub AddButtonToCells()
Dim button As Object
Dim cell As Range
For Each cell In ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas)
If Not HasPrecedents(cell) Then
Set button = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False, _
DisplayAsIcon:=False, Left:=cell.Left + cell.Width - 6, Top:=cell.Top + 1, _
Width:=15, Height:=22)
With button
.Object.Caption = "+"
.Object.BackColor = RGB(0, 255, 0)
.Object.ForeColor = RGB(255, 255, 255)
.Object.Font.Size = 12
.Object.Font.Name = "Arial"
.Object.Font.Bold = True
.Name = "Button_" & cell.Address
End With
With ThisWorkbook.VBProject.VBComponents(ActiveSheet.Name).CodeModule
.InsertLines .CreateEventProc("Click", "Button_" & cell.Address) + 1, "AddNumericValue " & cell.Address
End With
End If
Next cell
End Sub
Function HasPrecedents(rngCheck As Range) As Boolean
Dim lngSheetCounter As Long, lngRefCounter As Long, rngDep As Range
On Error Resume Next
With rngCheck
.ShowPrecedents False
Set rngDep = .NavigateArrow(True, 1, 1)
If rngDep.Address(External:=True) = rngCheck.Address(External:=True) Then
HasPrecedents = False
Else
HasPrecedents = (Err.Number = 0)
End If
.ShowPrecedents True
End With
End Function
Private Sub AddNumberToCell(cellAddress As String)
Dim str As String
Dim cellFormula As String
Dim cell As Range
Set cell = Range(cellAddress)
str = Application.InputBox("Enter addition to formula: ")
cellFormula = cell.formula
cellFormula = cellFormula & str
cell.formula = cellFormula
End Sub
Sub DeleteAllControls()
Dim obj As OLEObject
For Each obj In ActiveSheet.OLEObjects
obj.Delete
Next obj
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
' Check if the shape is a form button
If shp.Type = msoFormControl Then
' Delete the form button
shp.Delete
End If
Next shp
Dim startLine As Long
Dim endLine As Long
Dim i As Long
With ThisWorkbook.VBProject.VBComponents(ActiveSheet.Name).CodeModule
startLine = .ProcStartLine("AddNumericValue", vbext_pk_Proc)
endLine = .ProcCountLines("AddNumericValue", vbext_pk_Proc) + startLine
For i = endLine To startLine + 1 Step -1
.DeleteLines i
Next i
End With
End Sub
Bookmarks