Buttons in Excel. how can you simplify-CodePudding

I have this problem. I've only been doing VBA for about a week. I have a workbook where I created a button that copies a certain range in a row and pastes it into a table on another sheet. My problem is this: do I need to create a module for each button, or can I somehow simplify the code to create the same buttons for each row on the first sheet?

Sub SelectRangea()

    Sheets("Tournaments").Select
    Range("B4:G4").Select
    Application.CutCopyMode = False
    Selection.Copy

    With Sheets("Results")
       lst = .Range("A" & Rows.Count).End(xlUp).Row   1
       .Range("A" & lst).PasteSpecial xlPasteColumnWidths
       .Range("A" & lst).PasteSpecial xlPasteValues
    End With

End Sub

CodePudding user response：

You'll need to adjust the code accordingly but this will add a set of buttons for you as well as tell you the cell that the button was pressed from ...

Public Sub AddButtons()
    Dim lngRow As Long, rngCell As Range, objButton As Shape
    
    For lngRow = 1 To 10
        Set rngCell = Sheet1.Cells(lngRow, 1)
        
        Set objButton = Sheet1.Shapes.AddFormControl(xlButtonControl, rngCell.Left, rngCell.Top, rngCell.Width, rngCell.Height)
        objButton.OnAction = "ButtonPushAction"
    Next
End Sub

Public Sub ButtonPushAction()
    Dim objCaller As Shape
    
    Set objCaller = Sheet1.Shapes(Application.Caller)
    
    MsgBox "Top Cell = " & objCaller.TopLeftCell.Address & vbCrLf & _
        "Row = " & objCaller.TopLeftCell.Cells(1, 1).Row & vbCrLf & _
        "Column = " & objCaller.TopLeftCell.Cells(1, 1).Column, vbInformation, "Button Push"
End Sub

CodePudding user response：

I don't have access to an office environment, so I can't test the code below at the moment.

Do I need to create a module for each button?

We only need to create one module containing the macros needed by the buttons and we can use the same macro for all the buttons.

Can I somehow simplify the code to create the same buttons for each row on the first sheet?

All the buttons should be identical, except their names. They can be copies of each other.

I assume that you want to copy the row clicked. So I changed SelectRangea:

' Copy the code to a module
Public Sub SelectRangea(RowNumber As Integer)
    ' Copy the row clicked
    Sheets("Tournaments").Select
    Range("B" & RowNumber & ":G" & RowNumber).Select
    Application.CutCopyMode = False
    Selection.Copy

    ' Paste the row clocked
    With Sheets("Results")
       lst = .Range("A" & Rows.Count).End(xlUp).Row   1
       .Range("A" & lst).PasteSpecial xlPasteColumnWidths
       .Range("A" & lst).PasteSpecial xlPasteValues
    End With

End Sub

And here is the click handler for the buttons:

' Copy the code to a module
Public Sub MyButton_Click()
    Dim Btn As Object
    Dim RowNumber As Integer
    'Set Btn = ActiveSheet.Buttons(Application.Caller) ' either this
    Set Btn = ActiveSheet.Shapes(Application.Caller) ' or this
    With Btn.TopLeftCell 
        RowNumber = .Row
    End With 
    SelectRangea RowNumber
End Sub

Notes

We could create a macro that creates the buttons, if they don't exist, using Sheet.Shapes.AddShape.
We could create a macro that sets the .OnAction of all the buttons to MyButton_Click.
We could remove the buttons and use double-click instead. For example this will copy the double-clicked row:

' Copy the three lines to the corresponding function in your sheet module.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim RowNumber As Integer
    RowNumber = Target.Row
    SelectRangea RowNumber
End Sub

We should avoid the use of Copy and Select, as it can worsen the user experience. We should only use them when the user expects us to use them. Refactor the code to avoid using them. For example:

' Copy the code to a module
Public Sub SelectRangea(ByVal RowNumber As Integer)
    Dim Sht As WorkSheet
    Dim Rng As Range
    Dim Dat As Variant
    
    ' Copy the row clicked
    Set Sht = Sheets("Tournaments")
    Set Rng = Sht.Range("B" & RowNumber & ":G" & RowNumber)
    Dat = Rng
    ' Paste the row
    Set Sht = Sheets("Results")
    RowNumber = Sht.Range("A" & Sht.Rows.Count).End(xlUp).Row   1
    Set Rng = Sht.Range("B" & RowNumber & ":G" & RowNumber)
    Rng = Dat
    ' Fix column widths
    Sht.UsedRange.Columns.AutoFit 
End Sub

Notes

See also