Insert row based on location of an image, not the highlighted cell

AGibson73

New Member
Joined
Aug 2, 2020
Messages
5
Office Version
  1. 2016
Platform
  1. Windows
Hi all,

I was hoping someone might be able to assist with the following as I am a bit of an Excel macro novice.

I am trying to create a spreadsheet where users fill out the details in grey to create a budget. I have protected the sheet so users can only edit the cells in grey.

To make this spreadsheet as user friendly as possible, I have added 2 images in column G and assigned macros to them so users can copy or delete that row.
1.png


So when I click on the copy image in row 11, the macro copies the details into an inserted row below and the user then edits as required.

2.png


Then if I click the copy image in row 12, this copies those details into row 13 and the process continues.

3.png


The issue though is the row copy seems based on where the selected cell is, and nothing to do with the row the button is clicked on.

So in the screenshot below, I click on the copy image in row 12 but as the highlighted cell was B11, it copies those details from row 11 down (which would throw people a little).

4.png


5.png



Likewise (and more worryingly) for the delete button, if I wanted to delete row 13 but the highlighted cell was in row 12, the user unwittingly deletes the wrong person.

So what I think I need is for the macro to detect the row of the clicked image, and then set the focus to highlight a cell on that row, but I am having no joy in working out how.

My macros are as below:

Sub AddRowPersonnel()

'Take worksheet out of protected mode

ActiveSheet.Unprotect

'Select the existing row and copy it

ActiveCell.Rows("1:1").EntireRow.Select

Selection.Copy

'Move cursor down one row, insert new row, and then paste values into the new row

ActiveCell.Offset(1, 0).Range("A1").Select

Application.CutCopyMode = False

Selection.EntireRow.INSERT

ActiveCell.Offset(-1, 0).Rows("1:1").EntireRow.Select

Selection.Copy

ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select

ActiveSheet.Paste

'Put worksheet back into protected mode

ActiveSheet.protect DrawingObjects:=True, Contents:=True, Scenarios:=True

End Sub



Sub DeleteRowPersonnel()

‘ Unprotect worksheet

ActiveSheet.Unprotect

‘ Highlight selected row and delete it

ActiveCell.Rows("1:1").EntireRow.Select

Selection.Delete Shift:=xlUp

‘Put worksheet back into protected mode

ActiveSheet.protect DrawingObjects:=True, Contents:=True, Scenarios:=True

End Sub

Many thanks in advance!
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
See if this works for deleting rows
VBA Code:
Sub DeleteRowPersonnel()
With ActiveSheet
    .Unprotect
    .Shapes(Application.Caller).TopLeftCell.EntireRow.Delete
    .Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
End Sub
If it does as expected then a similar method can be applied to the copy section as well.
 
Upvote 0
Yes - wow this works a treat so many thanks!
I've had a crack at applying this approach to the copy section but my attempt below probably shows how rudimentary my current skills are.

Are you able to fill in this part of the puzzle for me? I'm going to take a few VBE and VBA tutorials after this so I can better understand and help myself/others in this space.

VBA Code:
    ActiveSheet.Unprotect
    ActiveSheet.Shapes(Application.Caller).TopLeftCell.EntireRow.Copy
    ActiveCell.Offset(1, 0).Range("A1").Select
    Application.CutCopyMode = False
    Selection.EntireRow.INSERT
    ActiveCell.Offset(-1, 0).Rows("1:1").EntireRow.Select
    Selection.Copy
    ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
    ActiveSheet.Paste
    ActiveSheet.protect DrawingObjects:=True, Contents:=True, Scenarios:=True
 
Upvote 0
Hopefully this one will work as well, but my luck is not usually that good on code that I haven't tested first.
VBA Code:
Sub AddRowPersonnel()
With ActiveSheet
    .Unprotect
     With Intersect(.Shapes(Application.Caller).TopLeftCell.EntireRow, .UsedRange)
        .Copy
        .Offset(1).Insert shift:=xlDown
    End With
    Application.CutCopyMode = False
    .Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
End Sub

A good way to learn some basics is to clean up code that you create with the macro recorder (it records a lot of superfluous actions, selection, scrolling, etc).

One thing to note when you start writing your own code, you don't need to select anything. Selection slows your code down but other than that it serves no purpose (except at the end of your code if you want the cursor to be left in a specific place when control is returned to the user).

The example below shows how to copy a small range with and without selection, you can do exactly the same for anything that needs selection.

VBA Code:
Sheets("Sheet1").Select
Range("A1:B10").Select
Selection.Copy

Sheets("Sheet1").Range("A1:B10").Copy

To carry out multiple tasks on the same range or sheet, you can use 'With' as I have done in your add and delete procedures. If you do this then you need to add a dot in front of any range commands, .Copy, .Paste, etc otherwise the code will run on the active sheet instead of the one that you specified.
 
Upvote 0
Thanks again. All works perfectly - and especially thanks for your prompt response
 
Upvote 0
Hi all,
I have a follow up question on this thread.

My macro uses the following code, but as it turns out for some reason get an error message. I can't determine the trigger for it as it seems to occur randomly. Any thoughts would be appreciated.

CODE:
Sub AddRow()
With ActiveSheet
.Unprotect
With Intersect(.Shapes(Application.Caller).TopLeftCell.EntireRow, .UsedRange)
.Copy
.Offset(1).Insert Shift:=xlDown
End With
Application.CutCopyMode = False
.protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End With

End Sub

ERROR MESSAGE
Run-time error '-21474178-48 (80010108)':
Method 'Insert' of object "Range' failed
 
Upvote 0

Forum statistics

Threads
1,213,484
Messages
6,113,923
Members
448,533
Latest member
thietbibeboiwasaco

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top