Назначение / запуск кода макроса от кнопки без необходимости отдельного макроса в Excel VBA

Question

Я написал макрос, который создает две кнопки на каждом листе в книге.Каждая кнопка запускает макрос сортировки, который сортирует определенный диапазон на каждом листе.Все макросы хранятся в файле PERSONAL.XLSB (см. Ниже).

Это прекрасно работает, однако, если я хочу поделиться этой книгой с другими, я должен экспортировать макросы 2-го рода (т.е. Module32.btnF и Module3.btnTD), и пользователь должен импортировать два макроса в свой файл PERSONAL.XLSB.Это работает, но, очевидно, не идеально.

Я бы хотел, чтобы макрос создавал кнопки сортировки, но запускал код сортировки без необходимости двух отдельных макросов сортировки.

Я создал два отдельныхпеременные, которые содержат код макроса для каждой сортировки, но они не будут / не запускаются из оператора .OnAction.

Я нашел некоторую информацию о VBProject.VBComponents, но не смог выяснить, как сделатьэта работа для моих требований.

Application.VBE.ActiveVBProject.VBComponents.Item("ws").CodeModule.AddFromString(strCode)

Примечание: ws - текущий рабочий лист, переменная strCode - с кодом сортировки.

Вот мой код:

Sub AddSortButtons1Point2()

    '
    '   Macro: AddSortButtons1Point2
    ' Purpose: Used to add sort button to each worksheet in the workbook.
    '
    '          1 - Sort Race Details by Field Order
    '          2 - Sort Race Details by TD Rating
    '

    Dim ws As Worksheet
    Dim btn1 As Button
    Dim btn2 As Button
    Dim NextFree As Integer
    Dim TwoDown As Integer
    Dim NextFreeF As Integer
    Dim NextFreeTD As Integer
    Dim t1 As Range
    Dim t2 As Range

    For Each ws In Sheets ' Select all worksheets in workbook.
        ws.Activate
        Application.ScreenUpdating = False
        ActiveSheet.Buttons.Delete
        NextFree = Range("F7:F" & _
        Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
        TwoDown = NextFree + 2
        Set t1 = ActiveSheet.Range(Cells(TwoDown, 6), Cells(TwoDown, 6))
        Set btn1 = ActiveSheet.Buttons.Add(t1.Left, t1.Top, t1.Width, t1.Height)
        With btn1
            .Placement = xlMove
            .OnAction = "btnF"
            .Caption = "Sort By Field Order"
            .Name = "Sort By Field Order"
        End With
        t1.Select
        Application.ScreenUpdating = True
        Set t2 = ActiveSheet.Range(Cells(TwoDown, 10), Cells(TwoDown, 10))
        Set btn2 = ActiveSheet.Buttons.Add(t2.Left, t2.Top, t2.Width, t2.Height)
        With btn2
           .Placement = xlMove
           .OnAction = "btnTD"
           .Caption = "Sort By TD Rating"
           .Name = "Sort By TD Rating"
        End With
        t2.Select
        Application.ScreenUpdating = True
        ' Code added to protect the buttons.
        ws.Protect DrawingObjects:=True, Contents:=False, Scenarios:=False, _
            AllowFormattingCells:=False, AllowFormattingColumns:=False, _
            AllowFormattingRows:=False, AllowInsertingColumns:=False, _
            AllowInsertingRows:=False, _
            AllowInsertingHyperlinks:=False, AllowDeletingColumns:=False, _
            AllowDeletingRows:=False, AllowSorting:=False, AllowFiltering:=False, _
            AllowUsingPivotTables:=False
    Next ws

End Sub

Sub btnF()

    '
    '   Macro: btnF (aka Module32.btnF)
    ' Purpose: Sort race details in field order (horse number).
    '

    NextFreeF = Range("B7:B" & _
        Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
    NextFreeF = NextFreeF - 1
    Range("B" & NextFreeF).Select
    Range("A7:P" & NextFreeF).Select
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("B7:B" & NextFreeF), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range("A7:P" & NextFreeF)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select

End Sub

Sub btnTD()

    '
    '   Macro: btnTD (aka Module3.btnTD)
    ' Purpose: Sort race details by TD Rating.
    '

    NextFreeTD = Range("B7:O" & _
        Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
    NextFreeTD = NextFreeTD - 1
    Range("B" & NextFreeTD).Select
    Range("A7:P" & NextFreeTD).Select
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("O7:O" & NextFreeTD), _
        SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        "AAA,AA,A,BBB,BB,B,CCC,CC,C,DDD,DD,D", DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range("A7:P" & NextFreeTD)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select

End Sub

К сожалению, я сейчас нахожусь в тупике.Любая помощь / руководство будет принята с благодарностью.

Answer 1

Хорошо, я думаю, что понял.Поэтому, возможно, хорошим решением будет скопировать макросы сортировки из PERSONAL.XLSB при добавлении кнопок.

[ПРАВИТЬ] Попробуйте добавить btnF () и btnTD () к новому модулю в PERSONAL.XLSB (назовем его «SortMacros»), а затем попробуйте следующее.

Sub AddSortButtons1Point2()

    '
    '   Macro: AddSortButtons1Point2
    ' Purpose: Used to add sort button to each worksheet in the workbook.
    '
    '          1 - Sort Race Details by Field Order
    '          2 - Sort Race Details by TD Rating
    '

    Dim ws As Worksheet
    Dim btn1 As Button
    Dim btn2 As Button
    Dim NextFree As Integer
    Dim TwoDown As Integer
    Dim NextFreeF As Integer
    Dim NextFreeTD As Integer
    Dim t1 As Range
    Dim t2 As Range

    For Each ws In Sheets ' Select all worksheets in workbook.
        ws.Activate
        Application.ScreenUpdating = False
        ActiveSheet.Buttons.Delete
        NextFree = Range("F7:F" & _
        Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
        TwoDown = NextFree + 2
        Set t1 = ActiveSheet.Range(Cells(TwoDown, 6), Cells(TwoDown, 6))
        Set btn1 = ActiveSheet.Buttons.Add(t1.Left, t1.Top, t1.Width, t1.Height)
        With btn1
            .Placement = xlMove
            .OnAction = ActiveWorkbook.Name & "!btnF"
            .Caption = "Sort By Field Order"
            .Name = "Sort By Field Order"
        End With
        t1.Select
        Application.ScreenUpdating = True
        Set t2 = ActiveSheet.Range(Cells(TwoDown, 10), Cells(TwoDown, 10))
        Set btn2 = ActiveSheet.Buttons.Add(t2.Left, t2.Top, t2.Width, t2.Height)
        With btn2
           .Placement = xlMove
           .OnAction = ActiveWorkbook.Name & "!btnTD"
           .Caption = "Sort By TD Rating"
           .Name = "Sort By TD Rating"
        End With
        t2.Select
        Application.ScreenUpdating = True
        ' Code added to protect the buttons.
        ws.Protect DrawingObjects:=True, Contents:=False, Scenarios:=False, _
            AllowFormattingCells:=False, AllowFormattingColumns:=False, _
            AllowFormattingRows:=False, AllowInsertingColumns:=False, _
            AllowInsertingRows:=False, _
            AllowInsertingHyperlinks:=False, AllowDeletingColumns:=False, _
            AllowDeletingRows:=False, AllowSorting:=False, AllowFiltering:=False, _
            AllowUsingPivotTables:=False
    Next ws

End Sub

Sub CopySortMacros()
        On Error GoTo endsub
        Dim sortMacrosModule As Object, destModule As Object

        Set sortMacrosModule = Workbooks("PERSONAL.XLSB").VBProject.VBComponents("SortMacros").CodeModule
        Set destModule = ActiveWorkbook.VBProject.VBComponents.Add(vbext_ct_StdModule).CodeModule

        destModule.Name = sortMacrosModule.Name
        destModule.AddFromString sortMacrosModule.Lines(1, sortMacrosModule.CountOfLines)

Exit Sub

endsub:
          With ActiveWorkbook.VBProject.VBComponents
              .Remove .Item(destModule.Name)
          End With
End Sub

Answer 2

Вместо этого вставьте модуль в свою рабочую книгу и просто переместите туда код из PERSONAL.XLSB.