Create button with different Find range

[bull699]

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.

S6rVs.png

Thanks in advance

[mikerickson]

You are going to end up with way too many buttons.
A DoubleClick event might serve you better.
If you put this in the code module for Sheet1, double clicking on any of the filled cells in column C will add the value in D to the others on the right.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim MatchingCell As Range
    
    With Target
        If .Column = 3 And .Value <> vbNullString Then
            Cancel = True
            Set MatchingCell = Me.Range("H:H").Find(what:=.Value, LookIn:=xlValues, MatchCase:=False)
            If Not MatchingCell Is Nothing Then
                With MatchingCell.Offset(0, 1)
                    .Value = Val(CStr(.Value) + Val(CStr(Target.Offset(0, 1).Value)))
                    Beep
                End With
            End If
        End If
    
    End With
End Sub