[英]Assign/run macro code from a button without the need for a separate macro in Excel VBA
我编写了一个宏,该宏在工作簿的每个工作表上创建两个按钮。 每个按钮运行一个排序宏,该宏对每个工作表中的特定范围进行排序。 所有宏都存储在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
不幸的是,我目前处于停滞状态。 任何帮助/指导将不胜感激。
好吧,我想我明白了。 因此,也许一个好的解决方案是在添加按钮时从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
而是在工作簿中插入一个模块,然后将代码从PERSONAL.XLSB移到那里。
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.