Create button with different Find range - vba

Question

Using this to create a button:-
Sub CreateButton4()
Dim i&
With ActiveSheet
i = .Shapes.Count
With .Buttons.Add(199.5, 20 + 46 * i, 81, 36)
.Name = "New Button" & Format(i, "00")
.OnAction = "MoveValue"
.Characters.Text = "Submit " & Format(i, "00")
End With
End With
That runs the MoveValue() sub:-
Sub MoveValue()
With Sheets("Sheet1").Columns(8).Find(Range("C3").Value, , , 1).Offset(0, 1)
.Value = .Value + Sheets("Sheet1").Range("D3").Value
End With
The problem is I want MoveValue() to relate to the cells adjacent to it as I have another sub which submits data to the adjacent cells when the button is created (at the moment I've only written it to work for the first button). Not sure if I'm going about this completely the wrong way. Any help would be appreciated.
Image Spreadsheet1

Answer 1

You can use the property TopLeftCell as shown here. But you have to change your layout like this, so the top left cell of your button is in the same row as the information you want.
Sub CreateButton4()
Dim i&
With ActiveSheet
i = .Shapes.Count
With .Buttons.Add(199.5, 35 + 46 * i, 81, 36)
.Name = "New Button" & Format(i, "00")
.OnAction = "MoveValue"
.Characters.Text = "Submit " & Format(i, "00")
End With
End With
End Sub
Sub MoveValue()
Dim tlcRow As Integer
tlcRow = ActiveSheet.Shapes(Application.Caller).TopLeftCell.row
With Plan1
.Range("H3:H8").Find(.Range("C" & tlcRow).Value).Offset(0, 1).Value = .Range("D" & tlcRow).Value
End With
End Sub