excel - 从按钮分配/运行宏代码，无需在 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

不幸的是，我目前处于停滞状态。任何帮助/指导将不胜感激。

标签： excelvba

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