通過按鈕分配/運行宏代碼，而無需在Excel VBA中使用單獨的宏

Question

我編寫了一個宏，該宏在工作簿的每個工作表上創建兩個按鈕。 每個按鈕運行一個排序宏，該宏對每個工作表中的特定范圍進行排序。 所有宏都存儲在PERSONAL.XLSB中（請參見下文）。

這很好，但是，如果我想與其他人共享此工作簿，則必須導出2個排序宏（即Module32.btnF和Module3.btnTD ），並且用戶必須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移到那里。