Delete item "Object required" excel VBA - vba

I understand what the problem is, but i don't have a clue on how to solve it...
So what I am doing is that I click on a button (addSceneButton) in my worksheet("costing") and it is going to insert a copy of another sheet("Scene Template") just above of the button (addSceneButton). It is also gonna create a button (deleteSceneButton) at the rightmost of the previously inserted sheet.
This button (deleteSceneButton), when clicked, must delete the region next to it.
It works ok if I only add 1 scene. But when I add more then one and then click on the deleteButton, it will automatically delete the last sheet inserted.
And when I want to delete a second one, it gives me the "Object Required" Error.
It must be because I overwrite the delteButtonPos instead of creating one dynamically but I dont know how.
Could someone help me on this ?
Here is my code
Public buttonPos As Range
Public deleteButtonPos As Range
Public deleteButton As Object
Private Sub AddSceneButton_Click()
Set buttonPos = Sheets(AddSceneButton.Parent.Name).Cells(AddSceneButton.TopLeftCell.Row - 1, _
AddSceneButton.TopLeftCell.Column)
Sheets("Scene Template").Activate
Sheets("Scene Template").Select
Sheets("Scene Template").Range("A1:H22").Select
Selection.Copy
Sheets("Costing").Select
buttonPos.Select
Selection.Insert Shift:=xlDown
'Insert the Add Scene Button
'Insert the Delete Button
Set deleteButtonPos = Selection.Range("H1")
Set deleteButton = ActiveSheet.Buttons.Add(deleteButtonPos.Left, _
deleteButtonPos.Top, _
deleteButtonPos.Width, _
deleteButtonPos.Height)
With deleteButton
.Caption = "Delete Button"
.Name = "deleteButtonFunct"
.OnAction = "Sheet1.deleteButtonFunct_Click"
End With
End Sub
Private Sub deleteButtonFunct_Click()
deleteButtonPos.Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
buttonPos.Select
End Sub

The reason why your code is throwing object required is because it cannot find the Button. So to correct that we need to set the button again after the first deletion.
Here I have added 3 more variables as public introw, selnum, colnum.
There is no change in the AddSceneButton sub part.
I have added an additional Check function to set the button again and to set the row number and column number correctly.
Check function is called within deleteButtonFunct sub, so that everytime when the delete button is clicked, it deletes the current/latest rows which is copied
to the sheet and sets a new delete button to the last column.
And if the Row number is 1, then there is no need to set an additional button, hence the condition inside the check function.
I have modified your code. Please find the updated code.
Public buttonPos As Range
Public deleteButtonPos As Range
Public deleteButton As Object
Public introw, selnum, colnum As Integer
Private Sub AddSceneButton_Click()
Set buttonPos = Sheets(AddSceneButton.Parent.Name).Cells(AddSceneButton.TopLeftCell.Row - 1, _
AddSceneButton.TopLeftCell.Column)
Sheets("Scene Template").Activate
Sheets("Scene Template").Select
Sheets("Scene Template").Range("A1:H22").Select
Selection.Copy
Sheets("Costing").Select
buttonPos.Select
Selection.Insert Shift:=xlDown
'Insert the Add Scene Button
'Insert the Delete Button
Set deleteButtonPos = Selection.Range("H1")
Set deleteButton = ActiveSheet.Buttons.Add(deleteButtonPos.Left, _
deleteButtonPos.Top, _
deleteButtonPos.Width, _
deleteButtonPos.Height)
With deleteButton
.Caption = "Delete Button"
.Name = "deleteButtonFunct"
.OnAction = "Sheet1.deleteButtonFunct_Click"
End With
End Sub
Private Sub deleteButtonFunct_Click()
deleteButtonPos.Select
Range(Selection, Selection.End(xlDown)).Select
introw = Selection.Count
Selection.EntireRow.Delete
buttonPos.Select
Call check
End Sub
Function check()
rownum = ActiveCell.Row
colnum = ActiveCell.Column
selnum = rownum - introw
If (rownum > 1) Then
Cells(selnum, colnum).Select
Set deleteButtonPos = Selection.Range("H1")
Set deleteButton = ActiveSheet.Buttons.Add(deleteButtonPos.Left, _
deleteButtonPos.Top, _
deleteButtonPos.Width, _
deleteButtonPos.Height)
With deleteButton
.Caption = "Delete Button"
.Name = "deleteButtonFunct"
.OnAction = "Sheet1.deleteButtonFunct_Click"
End With
End If
End Function
The code is tested and is working fine.
Hope this should help :)

The range variables buttonPos and deleteButtonPos only ever seem to contain a single cell ref. When you add the 2nd scene you need to add another cell to the range using the Application.Union() method. You'll need some way to associate the scenes to the respective delete button.

If you add the following code to a new module, it shows how you can uniquely handle all your dynamic buttons.
My example uses a number (count) to track and index the new buttons, it could be modified fairly simply to be a cell reference (to range you want to delete in your example).
Public Count As Integer ' Used to index the controls in my example
Sub addButton()
Dim P As Range: Set P = Selection
Dim B As Object
Dim S As String: S = CStr(Count) ' string representation of count
Set B = ActiveSheet.Buttons.Add(P.Left, P.Top, P.Width, P.Height)
With B
.Caption = "Id#" & S
.Name = "Id" & S
.onAction = "'onAction " & Chr(34) & S & Chr(34) & "'"
End With
Count = Count + 1 ' Increase the counter
End Sub
Public Sub onAction(ByVal Index As String)
MsgBox "You Pressed Button #" & Index & "!", vbOKOnly, "Action"
End Sub

Related

Excel VBA Onaction with .Select or .ScrollColumn

Good Morning everyone,
I am facing a strange Problem in Excel VBA.
So, I have this minimal Example. The only thing it's supposed to do is, add a Button to the Rightklick context menu. This button should then select a cell.
I searched a bit on StackOverflow and found a solution to passing string arguments in .onaction. But then it gets tricky. I can assign a Range and I can Print the Address and the second Argument in a Mesgbox. But I can't set Breakpoints and even stop doesn't work, nor will .select or .ScrollColumn do anything.
To Replicate just copy the Following code into a standard Module and Execute AddContextmenu to add the Button to the Contextmenu.
Option Explicit
Public Sub AddContextmenu()
Dim MySubMenu As CommandBarControl
Dim i As Long
'Clear Previous Menu Items
For Each MySubMenu In Application.CommandBars("Cell").Controls
If Not MySubMenu.BuiltIn Then
MySubMenu.Delete
End If
Next
'add menu
AddScrollButtons Application.CommandBars("Cell"), 1
End Sub
Public Sub AddScrollButtons(ByVal ContextMenu As CommandBar, ByVal baseindex As Long)
Dim cbb As CommandBarButton
Dim sFunction As String
'Add Button
Set cbb = ContextMenu.Controls.Add(Temporary:=True)
With cbb
sFunction = BuildProcArgString("ScrolltoColTest", "$F$10", "TestArg") ' Get Onaction string
.OnAction = sFunction
.Caption = "Scroll Tester"
.Style = msoButtonAutomatic
End With
End Sub
Function BuildProcArgString(ByVal ProcName As String, ParamArray Args() As Variant)
Dim tempArg As Variant
Dim temp As String
For Each tempArg In Args
temp = temp + Chr(34) + tempArg + Chr(34) + ","
Next
BuildProcArgString = "'" & ThisWorkbook.Name & "'!" & ProcName + "(" + Left(temp, Len(temp) - 1) + ")" ' (Workbook has to be included to ensure that the sub will be executed in the correct workbook)
End Function
Public Sub ScrolltoColTest(Addr As String, OtherArg As String)
Dim cell As Range
Set cell = ActiveSheet.Range(Addr) 'Get Cell that sould be selected from Addr
MsgBox cell.Address & vbNewLine & OtherArg 'Test if the Arguments have been passed correctly and the cell has been assigned
Stop 'Why doesn' this stop?
cell.Select 'Why doesn't this do anything
ActiveWindow.ScrollColumn = cell.Column 'Why doesn't this do anything
End Sub
As you will see in ScrolltoColTest the Part after the Msgbox will not work at all.
Does anyone know why that happens?

Rowsource behavior not updating/resetting the listbox without reloading the userform // getting column headers with list = ranges

I have the following code that works, BUT only on me unloading(x) the userform and reloading it. The listbox(being the DatabaseViewer) loads on userform initialize.
The testbutton will take the string input on a TextBox and fuzzy search the original database and copy out the database to a temporary sheet which allows for the rowsource formula to work.
I would have preferred to use list = Ranges instead of RowSource but from my google searches it appears that that is the only way to get headers reliably, if there is an alternative to getting headers please do share!!
Private Sub testButton_Click()
Dim dataworksheet As String
dataworksheet = ActiveSheet.Name
MsgBox (dataworksheet)
Range(Cells(getFirstDataAreaRow, getApplicableColumn("Original Name")), Cells(getLastDataAreaRow, getApplicableColumn("Original Name"))).AutoFilter Field:=1, Criteria1:="*" & searchByName.Value & "*"
Range(Cells(getFirstDataAreaRow, getApplicableColumn("Number")), Cells(getLastDataAreaRow, getlastDataAreaColumn)).SpecialCells(xlCellTypeVisible).Copy
Sheets("Temp").Activate
Range("A1").Select
ActiveSheet.Paste
Sheets(dataworksheet).Activate
MsgBox (dataworksheet)
Dim TempDataArea As Range
Set TempDataArea = Range(ThisWorkbook.Sheets("Temp").Cells(getFirstDataAreaRow("Temp") + 1, getlastDataAreaColumn("Temp")), ThisWorkbook.Sheets("Temp").Cells(getLastDataAreaRow("Temp"), getlastDataAreaColumn("Temp")))
With databaseViewer
.ColumnCount = getlastDataAreaColumn("Temp")
.ColumnHeads = True 'only works if you are using rowsource
.ColumnWidths = "0;;4 in" 'THIS SETS the number column to HIDDEN!
.RowSource = TempDataArea.Cells.Address 'rowsouce only works with address, .list works with ranges
End With
End Sub

Add Hyperlink to a cell in a Table using VBA - Excel

I have an Excel with two sheets named "Complaints" and "Add Row".
I am using the Add Row sheet to add a row (after the last row with values) to a table named ComplaintsTable in Complaints sheet and I am using a macro paired with a command button to do this.
My code looks like this:
Private Sub CommandButton1_Click()
Dim LastRow As Long, ws As Worksheet, ws1 As Worksheet, newRow As ListRow
Set ws = Sheets("Complaints")
Set ws1 = Sheets("Add Row")
Set tbl = ws.ListObjects("ComplaintsTable")
Set newRow = tbl.ListRows.Add
With newRow
.Range(2) = ws1.Range("C1").Value 'Complaint Yes/No
.Range(12) = ws1.Range("C6").Value 'PCE Yes/No
End With
newRow.Range(4) = ws1.Range("C4").Value 'Subject
newRow.Range(21) = ws1.Range("C5").Value 'Entered Date
'To add Hyperlink
If (ws1.Range("C1").Value = "Yes") Then
ws.Hyperlinks.Add Anchor:=tbl.newRow.Range(3), _
Address:=ws1.Range("F3").Value, _
ScreenTip:="Open Complaint in EtQ", _
TextToDisplay:=Worksheets("Add Row").Range("F2").Value
End If
If (ws1.Range("C6").Value = "Yes") Then
'To add hyperlink and PCE Number
ws.Hyperlinks.Add Anchor:=tbl.newRow.Range(13), _
Address:=ws1.Range("F8").Value, _
ScreenTip:="Open PCE in EtQ", _
TextToDisplay:=ws1.Range("F7").Value
End If
End Sub
Somehow when I clicked the command button to add values it doesn't add anything! Where am I going wrong?
Here is your refactored, cleaned up code with screenshots. As mentioned by both #Ibo and myself, The problem most likely lies in the fact that you've declared and set newRow as a range but then used it as a property of your table which is impossible.
Option Explicit
Private Sub CommandButton1_Click()
Dim wsComplaints As Worksheet, wsAddRow As Worksheet
Dim tblComplaints As ListObject
Dim lngRows As Long
With ThisWorkbook
Set wsComplaints = .Worksheets("Complaints")
Set wsAddRow = .Worksheets("Add Row")
End With
Set tblComplaints = wsComplaints.ListObjects("ComplaintsTable")
tblComplaints.ListRows.Add
lngRows = tblComplaints.ListRows.Count
With tblComplaints
.DataBodyRange(lngRows, 2) = wsAddRow.Cells(1, 3)
.DataBodyRange(lngRows, 4) = wsAddRow.Cells(4, 3)
.DataBodyRange(lngRows, 12) = wsAddRow.Cells(6, 3)
.DataBodyRange(lngRows, 21) = wsAddRow.Cells(5, 3)
End With
If wsAddRow.Cells(1, 3) = "Yes" Then
tblComplaints.DataBodyRange(lngRows, 3).Hyperlinks.Add _
Anchor:=tblComplaints.DataBodyRange(lngRows, 3), _
Address:=CStr(wsAddRow.Cells(3, 6)), _
ScreenTip:="Open complaint in EtQ", _
TextToDisplay:=CStr(wsAddRow.Cells(2, 6))
End If
If wsAddRow.Cells(6, 3) = "Yes" Then
tblComplaints.DataBodyRange.Hyperlinks.Add _
Anchor:=tblComplaints.DataBodyRange(lngRows, 13), _
Address:=CStr(wsAddRow.Cells(8, 6)), _
ScreenTip:="Open PCE in EtQ", _
TextToDisplay:=CStr(wsAddRow.Cells(7, 6))
End If
End Sub
Screenshots of the solution.
If you click the button and nothing, not even an error of any sort, happens there may be several issues.
To start of with, as mentioned by #Carol, the newRow is not supposed to be qualified by tbl as newRow is not a property or method of tbl
Possibility 1:
You've added a Form Control button to your sheet which you are unable to assign a Private Sub CommandButton1_Click() because, well, it is private and can only be used within the code module it is placed in, it cannot be referenced outside of it.
Possibility 2:
You've added an ActiveX CommandButton, wrote the Private Sub CommandButton1_Click() but then changed the name of the button. In that case, change the CommandButton1 to whatever you've named your button.
Possibility 3:
You've encountered an error, hit debug and the code is paused. As long as the code is paused, no new event will fire and thus your button will appear to do nothing. This is recognized by a line of your code highlighted in yellow. You need to fix the line which caused the error and resume your code by hitting F5 or hitting the stop icon usually located somewhere near the top of your VBA window.
Your text to display must be a zero-length string and that is it is failing to create the hyperlink.
define the text to display like this before to make sure this line is the problem:
myStr=Worksheets("Add Row").Range("F2").Value
Try to define variables and range objects before adding the hyperlink, instead of using the .value etc put them in a string variable and make sure all of them have a valid value. If you try this, it should work, otherwise follow the above instruction and you will find where the problem is:
Replace this block and if it worked, change the other block in the same way:
If (ws1.Range("C1").Value = "Yes") Then
ws.Hyperlinks.Add Anchor:=tbl.newRow.Range(3), _
Address:=ws1.Range("F3").Value, _
ScreenTip:="Open Complaint in EtQ", _
TextToDisplay:=IIf(mystr <> "", mystr, "Click Here")
End If
I have changed the code as follows and it is working perfectly fine without any errors.
Private Sub AddRow_Click()
Dim LastRow As Long, ws As Worksheet, ws1 As Worksheet
Dim newRow As ListRow ', tbl As ListObjects
Dim cmpNo As String, pceNo As String
Set ws = Sheets("Complaints")
Set ws1 = Sheets("AddRow")
Set tbl = ws.ListObjects("ComplaintsTable")
Set newRow = tbl.ListRows.Add
With newRow
.Range(1) = ws1.Range("C1").Value 'Complaint Yes/No
.Range(11) = ws1.Range("C6").Value 'PCE Yes/No
.Range(3) = ws1.Range("C4").Value 'Subject
.Range(20) = ws1.Range("C5").Value 'Entered Date
End With
'To add Hyperlink
If (ws1.Range("C1").Value = "Yes") Then
Call ActiveSheet.Hyperlinks.Add(newRow.Range(2), ws1.Range("F3").Value, "", "Open in EtQ", ws1.Range("F2").Value)
End If
If (ws1.Range("C6").Value = "Yes") Then
Call ActiveSheet.Hyperlinks.Add(newRow.Range(12), ws1.Range("F8").Value, "", "Open in EtQ", ws1.Range("F7").Value)
'To add hyperlink and PCE Number
End If
End Sub
The problem with the code is that "newRow.Range" does not work with the " hyperlinks.add". I fugered out this a few days ago but I didn't get a chance to post this.
I appreciate all your help!

How to prevent dropdown from executing when source list is changed programmatically

I have an activeX dropdown form on my spreadsheet which executes code on _Change. My code modifies the dropdowns list source (adding or deleting items). Whenever this happens, the _Change is called again.
I have various workarounds, all of which were some version of changing the list source, but with no success. The reason none of this has worked is because clearing or altering the .ListFillRange actually triggers the _Change event again.
How do I prevent the _Changeevent from getting called if I want to add or delete items in the .ListFillRange
UPDATE w EnableEvents set to false:
Public Sub SetRangeForDropdown()
On Error Resume Next
Application.EnableEvents = False
'Get new List of employees from Employee sheet
Dim rng1 As Range
With wsDB_employee
Set rng1 = .Range("A2:B" & .Range("A10000").End(xlUp).Row)
End With
With wsStage
.Cells.Clear
rng1.Copy .Range(.Cells(1, 1), .Cells(rng1.Rows.Count, 2))
End With
'Set range for dropdown on employee sheet
Dim rng2 As Range
Set rng2 = wsStage.Range("A1:B" & wsStage.Range("A10000").End(xlUp).Row)
'Update employee list named formula
ActiveWorkbook.Names.Add Name:="nfEmployeeList", RefersTo:=rng2
Dim str As String
str = rng2.Parent.Name & "!" & rng2.Address 'Source path for list fill range
wsMA.cmbEmployeeSelection.ListFillRange = str
Application.EnableEvents = True
End Sub
Apperantly EnableEvents does not work for ActiveX controls.
Thank you Microsoft for making life just a little bit more complicated!
Just found this: "Application.EnableEvents=False/True ONLY applies to Sheet and Workbook Events, not ActiveX Control Events" from here enter link description here
You can disable the events in the SetRangeForDropdown and then enable them back.
So, write the following at the start:
Application.EnableEvents = False
And the following at the end:
Application.EnableEvents = true
it's always a good habit to make (nearly) sure that events handling is always brought back, like follows:
Public Sub SetRangeForDropdown()
'...your code
On Error GoTo ExitSub
Application.EnableEvents = False
wsMA.cmbEmployeeSelection.ListFillRange = rng2
'Update employee list named formula
ActiveWorkbook.Names.Add name:="nfEmployeeList", RefersTo:=rng2
ExitSub:
Application.EnableEvents = True
End Sub
Furthermore, avoid On Error Resume Next unless you really need it
I have solved the problem by adding a global variable that prevents the _Change event from firing. Here is that code:
Private Sub cmbEmployeeSelection_Change()
If bNOTRUN = False Then 'Check if ActiveX event should fire or not
modEmployeeDB.SaveEmployeeData 'Save currently selected employee data
modEmployeeDB.DBSoll_To_WorkerInfo 'Get called employee data
End If
End Sub
And this is the module as modified... note the simple Boolean variable that I added:
Public Sub SetRangeForDropdown()
On Error GoTo SetRangeForDropdown_Error
bNOTRUN = True 'Global Variable that when True prevents Active X from firing
'Get new List of employees from Employee sheet
Dim rng1 As Range
With wsDB_employee
Set rng1 = .Range("A2:B" & .Range("A10000").End(xlUp).Row)
End With
With wsStage
.Cells.Clear
rng1.Copy .Range(.Cells(1, 1), .Cells(rng1.Rows.Count, 2))
End With
'Set range for dropdown on employee sheet
Dim rng2 As Range
Set rng2 = wsStage.Range("A1:B" & wsStage.Range("A10000").End(xlUp).Row)
'Update employee list named formula
ActiveWorkbook.Names.Add Name:="nfEmployeeList", RefersTo:=rng2
Dim str As String
str = rng2.Parent.Name & "!" & rng2.Address 'Source path for list fill range
wsMA.cmbEmployeeSelection.ListFillRange = str
bNOTRUN = False
On Error GoTo 0
Exit Sub
SetRangeForDropdown_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure SetRangeForDropdown of Sub modEmployeeDB"
bNOTRUN = False
End Sub

Displaying only a determined range of data

I want to display to the user certain information that exists on a separated worksheet, whenever he clicks a button.
I can set Excel to "go" to this worksheet at the starting line of the range , but I could not find a way to hide everything else.
Is there some method for this, or do I have to hide all rows and columns?
Insert a UserForm in the Workbook's VB Project.
Add a ListBox control to the userform.
Then do something like this code in the UserForm_Activate event code:
Private Sub UserForm_Activate()
Dim tbl As Range
Set tbl = Range("B2:E7") '## Change this to capture the rang you need '
Me.Caption = "Displaying data from " & _
ActiveSheet.Name & "!" & tbl.Address
With ListBox1
.ColumnHeads = False
.ColumnCount = tbl.Columns.Count
.RowSource = tbl.Address
End With
End Sub
Which gives unformatted data from the range:
To export the range as an image, you could create an Image in the UserForm instead of a Listbox. Then this should be enough to get you started.
As you can see from this screenshot, the image might not always come out very clearly. Also, if you are working with a large range of cells, the image might not fit on your userform, etc. I will leave figuring that part out up to you :)
Private Sub UserForm_Activate()
Dim tbl As Range
Dim imgPath As String
Set tbl = Range("B2:E7") '## Change this to capture the rang you need '
imgPath = Export_Range_Images(tbl)
Caption = "Displaying data from " & _
ActiveSheet.Name & "!" & tbl.Address
With Image1
If Not imgPath = vbNullString Then
.Picture = LoadPicture(imgPath)
.PictureSizeMode = fmPictureSizeModeClip
.PictureAlignment = 2 'Center
.PictureTiling = False
.SpecialEffect = 2 'Sunken
End If
End With
End Sub
Function Export_Range_Images(rng As Range) As String
'## Modified by David Zemens with
' credit to: _
' http://vbadud.blogspot.com/2010/06/how-to-save-excel-range-as-image-using.html ##'
Dim ocht As Object
Dim srs As Series
rng.CopyPicture xlScreen, xlPicture
ActiveSheet.Paste
Set ocht = ActiveSheet.Shapes.AddChart
For Each srs In ocht.Chart.SeriesCollection
srs.Delete
Next
'## Modify this line as needed ##'
fname = "C:\users\david_zemens\desktop\picture.jpg"
On Error Resume Next
Kill fname
On Error GoTo 0
ocht.Width = rng.Width
ocht.Height = rng.Height
ocht.Chart.Paste
ocht.Chart.Export Filename:=fname, FilterName:="JPG"
Application.DisplayAlerts = False
ocht.Delete
Application.DisplayAlerts = True
Set ocht = Nothing
Export_Range_Images = fname
End Function
If you record a macro and hide some columns and rows manually, the code will be produced for you, and you will see how it's done.