lundi 21 octobre 2019

Multi-optional macros using removeable checkboxes

everyone.

Thanks to these instructions How do I assign a Macro to a checkbox dynamically using VBA https://social.msdn.microsoft.com/Forums/office/en-US/877f15da-bbe4-4026-8ef2-8df77e1022f7/how-do-i-assign-a-macro-to-a-checkbox-dynamically-using-vba?forum=exceldev

I came up with an idea to:

  1. Put checkboxes where I want on the sheet, e.g. in columns right of table with data for processing
  2. Connect their (un)checking with logical variables which are used whether to start or not to start some procedures.
  3. Wait for user to make his choices and check certain checkbox (e.g. the last in the list) to start selected procedures
  4. Remove all (!) checkboxes and start the procedures selected shortly before. This way the macros containing optional procedures are portable, as they don't DEPEND on the opened files but only WORK on them. The files themselves remain unchanged by these free from control buttons coded in the macro (i.e. the sheet with checkboxes returns to it's previous state).

Example: The following macro makes its own checkboxes (in column H), waits for user to choose options, memorizes choices, deletes all checkboxes, runs other procedures... and ends up without leaving a trace of itself in a workbook.

Dim FirstOptionLogical, SecondOptionLogical, ThirdOptionLogical As Boolean

' Making new checkboxes

Sub CheckBOxAdding()
Dim i As Long, id As Long
Dim cel As Range
Dim cbx As CheckBox

On Error GoTo CheckBoxAddingERROR

'FirstOptionLogical = False
'SecondOptionLogical = False
'ThirdOptionLogical = False

    ' Deleting all checkboxes, if any found
    ' Preventing error stops if there is no checkbox
    On Error Resume Next
    ' Repeating with all checkboxes on active sheet
    For Each chkbx In ActiveSheet.CheckBoxes

    ' Removing a checkbox
    chkbx.Delete

    ' Next checkbox
    Next

    Range("G3").Select
    ActiveSheet.Range(Columns("G:G"), Selection.End(xlToRight)).Select
    Selection.Delete Shift:=xlToLeft
    On Error GoTo 0

    Set cel = ActiveSheet.Cells(3, 8)
    With cel
        Set cbx = ActiveSheet.CheckBoxes.Add(.Left, .Top, 90, 3)
' height will autosize larger to the font
    End With
    cbx.Name = "Option_1"
    cbx.Caption = "First Attribute changes, name it"
    cbx.Display3DShading = True

 ' with a linked can trap sheet change event or link to other formulas
        cbx.LinkedCell = cel.Offset(0, -1).Address
        cbx.OnAction = "'" & ThisWorkbook.Name & "'!CheckBoxHandling"
''''''''''   

    Set cel = ActiveSheet.Cells(5, 8)
    With cel
        Set cbx = ActiveSheet.CheckBoxes.Add(.Left, .Top, 90, 3)
' height will autosize larger to the font
    End With
    cbx.Name = "Option_2"
    cbx.Caption = "Second Attribute changes, name it"
    cbx.Display3DShading = True

 ' with a linked can trap sheet change event or link to other formulas
        cbx.LinkedCell = cel.Offset(0, -1).Address
        cbx.OnAction = "'" & ThisWorkbook.Name & "'!CheckBoxHandling"

    Set cel = ActiveSheet.Cells(7, 8)
    With cel
        Set cbx = ActiveSheet.CheckBoxes.Add(.Left, .Top, 90, 3)
' height will autosize larger to the font
    End With
    cbx.Name = "Option_3"
    cbx.Caption = "Third Attribute changes, name it"
    cbx.Display3DShading = True

 ' with a linked can trap sheet change event or link to other formulas
        cbx.LinkedCell = cel.Offset(0, -1).Address
        cbx.OnAction = "'" & ThisWorkbook.Name & "'!CheckBoxHandling"

    Set cel = ActiveSheet.Cells(9, 8)
    With cel
        Set cbx = ActiveSheet.CheckBoxes.Add(.Left, .Top, 90, 3)
        ' .Font.Size = 36

' height will autosize larger to the font
    End With
    cbx.Name = "Option_4"
    cbx.Caption = "START THE MACRO"
    cbx.Display3DShading = True


 ' with a linked can trap sheet change event or link to other formulas
        cbx.LinkedCell = cel.Offset(0, -1).Address
        cbx.OnAction = "'" & ThisWorkbook.Name & "'!CheckBoxHandling"

Exit Sub

CheckBoxAddingERROR:

   MsgBox "Something went wrong... ;-) in the sub CheckBOxDodavanje", vbCritical + vbOKOnly
   End

End Sub

Sub CheckBoxHandling()
Dim sCaller, UsersChoice As String
Dim id As Long
Dim cbx As CheckBox
Dim shp As Shape

UsersChoice = ""

On Error GoTo CheckBoxHandlingERROR

    sCaller = Application.Caller
    Set shp = ActiveSheet.Shapes(sCaller)
    Set cbx = ActiveSheet.CheckBoxes(sCaller)

    id = Val(Mid$(sCaller, Len("Option_") + 1, 5))

    ' maybe something based on Select Case?
    Select Case id
        Case 1:
            'MsgBox "You clicked the checkbox with option" & vbCrLf & "'Larger description of First Attribute changes, name it'"
            FirstOptionLogical = Not FirstOptionLogical
            'FirstOptionLogical = IIf(cbx.Value = xlOn, True, False)
            'MsgBox "FirstOptionLogical = " & FirstOptionLogical & vbCrLf & "SecondOptionLogical = " & SecondOptionLogical & vbCrLf & "ThirdOptionLogical= " & ThirdOptionLogical
        Case 2:
            'MsgBox "Kliknut je box sa opcijom" & vbCrLf & "'Larger description of Second Attribute changes, name it'"
            SecondOptionLogical = Not SecondOptionLogical
            'SecondOptionLogical = IIf(cbx.Value = xlOn, True, False)
            'MsgBox "FirstOptionLogical = " & FirstOptionLogical & vbCrLf & "SecondOptionLogical = " & SecondOptionLogical & vbCrLf & "ThirdOptionLogical= " & ThirdOptionLogical
        Case 3:
            'MsgBox "Kliknut je box sa opcijom" & vbCrLf & "'Larger description of Third Attribute changes, name it'"
            ThirdOptionLogical = Not ThirdOptionLogical
            'ThirdOptionLogical = IIf(cbx.Value = xlOn, True, False)
            'MsgBox "FirstOptionLogical = " & FirstOptionLogical & vbCrLf & "SecondOptionLogical = " & SecondOptionLogical & vbCrLf & "ThirdOptionLogical= " & ThirdOptionLogical
        Case 4:
            If FirstOptionLogical Then
                UsersChoice = UsersChoice & "- Larger description of First Attribute changes, name it " & vbCrLf
            End If
            If SecondOptionLogical Then
                UsersChoice = UsersChoice & "- Larger description of Second Attribute changes, name it " & vbCrLf
            End If
            If ThirdOptionLogical Then
                UsersChoice = UsersChoice & "- Larger description of Third Attribute changes, name it " & vbCrLf
            End If

            Ans0 = MsgBox("The following options were chosen:" & vbCrLf & UsersChoice & vbCrLf & vbCrLf & _
                    "You chose a checkbox with an option" & vbCrLf & "'START THE MACRO'" & vbCrLf & vbCrLf & " S H O U L D   W E   S T A R T   T H E   M A C R O ? ", vbYesNo + vbDefaultButton2 + vbQuestion)

            If Ans0 = vbYes Then

                'MACRO WITH PARAMETERS WE CHOSE BY CLICKING GETS STARTED...
        ' Delete all remaining checkboxes, if any (removing traces of the macro)

                ' In case of error, resume
        On Error Resume Next
        For Each chkbx In ActiveSheet.CheckBoxes
            chkbx.Delete
        Next

                ' Deleting all columns from G to the right
                Range("G3").Select
                ActiveWorkbook.Sheets(1).Range(Columns("G:G"), Selection.End(xlToRight)).Select
                Selection.Delete Shift:=xlToLeft

        ' Resetting on Error event to default
                On Error GoTo 0

                ' If chosen, start sub 'Larger description of First Attribute changes, name it'
                If FirstOptionLogical Then Call RunFirstOptionSub ' Name of the Sub

                ' If chosen, start sub 'Larger description of Second Attribute changes, name it'
                If SecondOptionLogical Then Call RunSecondOptionSub ' Name of the Sub

                ' If chosen, start sub 'Larger description of Third Second Attribute changes, name it'
                If ThirdOptionLogical Then Call RunThirdOptionSub ' Name of the Sub

            Else

                If Ans0 = vbNo Then

                End If

            End If

            Exit Sub

    End Select

    cbx.TopLeftCell.Offset(, 2).Interior.Color = IIf(cbx.Value = xlOn, vbGreen, vbRed)
    'MsgBox cbx.Caption & vbCr & IIf(cbx.Value = xlOn, " is ", " is not ") & "chosen"

Exit Sub

CheckBoxHandlingERROR:
   MsgBox "Something went wrong... ;-) in the Sub CheckBoxHandling", vbCritical + vbOKOnly

End Sub

Sub RunFirstOptionSub()
' CODE
End Sub

Sub RunSecondOptionSub()
' CODE
End Sub

Sub RunThirdOptionSub()
' CODE
End Sub

Sub MacroWithOptionsEndsWithoutATrace()

FirstOptionLogical = False
SecondOptionLogical = False
ThirdOptionLogical = False

' OPTIONAL: Delete all remaining checkboxes, if any (most important when testing macro)

On Error Resume Next
For Each chkbx In ActiveSheet.CheckBoxes
    chkbx.Delete
Next

' Resetting on Error event to default
On Error GoTo 0

CheckBOxAdding

End Sub

Share and use as you wish, as I used other's knowledge and experience. I am very sorry, but I haven't found any other solution to present this to you, and I also haven't found anyone else presenting something similar to this.




Aucun commentaire:

Enregistrer un commentaire