学习Excel技术，关注微信公众号：

excelperfect

在前面的一系列主题中，你已经学到了很多小的修改工作簿外观的VBA代码。下面，我们将介绍一个简单的示例程序，实现下面的功能特点：

1. 当打开工作簿时，

1.1 激活特定的工作表（名为Sample）。

1.2 开始的3行被冻洁。

1.3一个特定的行（行50）向上滚动并成为解冻窗格的顶部行。

1.4 活动工作表的滚动区域限制为某个单元格区域（A4:H100）。

1.5 一个自定义选项卡（名为Custom）被激活。

1.6 在运行时动态地使用项目（其标签为：AllGroups,Group1,Group2,Group3,Groups 1 and 2,Groups 1 and 3,和Groups 2 and3）填充一个下拉控件。

1.7 运行时使用图像动态地填充库控件。

2. 当用户从Custom选项卡的下拉控件中选择不同的项目时，

2.1 仅相应地显示选项卡中某组控件（AllGroups,Group1,Group2,Group3,Groups 1 and 2,Groups 1 and 3,或Groups 2 and3）。

2.2 状态栏显示当前选择的项目。

2.3 如果选择了指定的项目（例如Group2），那么激活指定的工作表（名为Sheet2），并对其外观作出下面的改变：

2.3.1 在页面布局视图中显示工作表

2.3.2 隐藏行和列标题

2.3.3 删除工作表中的网格线

2.3.4 隐藏公式栏

3. 如果激活的工作表是标准工作表，那么Custom选项卡是可见的。

4. 如果取消选取（或选取）指定的内置复选框（例如，在“视图”选项卡中的“编辑栏”复选框），那么禁用（或启用）自定义控件（例如，在“视图”选项卡中的G5B1按钮）。

5. 如果激活的工作表（名为Sheet1）具有指定的工作表级命名区域（例如，名为MyRange的单元格区域），那么启用Custom选项卡中不同组中的一组控件按钮。（例如，在Group 1中的G1B1，在Group 2中的G2B2，在Group 3中的G3B3，在Group 4中的G4B3）

6. 能够从单元格上下文菜单中访问自定义控件（名为Remove USD）。

要创建这个程序，执行下列步骤：

1. 创建一个新工作簿，将其保存为启用宏的工作簿。

2. 右击工作表选项卡，选择插入来添加一个图表工作表。

3. 重命名工作表为Sample、Sheet1和Sheet2。

4. 激活工作表Sheet1，选择一个单元格区域，在“名称”框中输入“Sheet1!MyRange”来命名为一个工作表级的名称。

5. 关闭该工作簿，然后在Custom UIEditor中打开该工作簿。

6. 在Custom UI Editor中，单击Insert|Office2010 Custom UI Part。

7. 复制并粘贴下面的XML代码：

8. 单击工具栏中的Validate按钮来检查是否有错误。

9. 保存并关闭该文件。

10. 在Excel中打开该文件。对于错误消息单击“确定”。

11. 按Alt+F11激活VBE。

12. 插入标准的VBA模块，复制并粘贴下列VBA代码：

Public myRibbon As IRibbonUI
'库中图像的数量
Dim ImageCount As Long
'图像的文件名
Dim ImageFilenames() As String
'下拉项标签
Dim ItemLabels(0 To 6) AsString
'存储可见的组名
Dim VisGrpNm1 As String
'从下拉项中选择某项时
Dim VisGrpNm2 As String
'customUI.onLoad回调
Sub Initialize(ribbon AsIRibbonUI)
    Set myRibbon = ribbon
    '激活Custom选项卡
    myRibbon.ActivateTab "CustomTab"
    '不在在Workbook_Open中放置上面的代码行
    '因为myRibbon仍然是Nothing
    '准备库图像的文件名
    Call PrepareItemImages
    '准备下拉项的标签
    Call PrepareItemLabels
End Sub
Private Sub PrepareItemImages()
'为库中的图像的文件名创建数组
    Dim Filename As String
    Filename = Dir("C:\Photos\*.jpg")
    '遍历文件夹中的所有jpg文件
    '使用jpg的文件名填充ImageFilenames数组
    Do While Filename <> ""
        ImageCount = ImageCount + 1
        ReDim Preserve ImageFilenames(1 ToImageCount)
        ImageFilenames(ImageCount) = Filename
        Filename = Dir
    'Dir() 返回一个零长字符串("")
    '当没有更多的文件在文件夹中时
End Sub
Private Sub PrepareItemLabels()
    '为下拉项创建项目标签数组
    Dim i As Long
    ItemLabels(0) = "All Groups"
    ItemLabels(1) = "Group 1"
    ItemLabels(2) = "Group 2"
    ItemLabels(3) = "Group 3"
    ItemLabels(4) = "Groups 1 and 2"
    ItemLabels(5) = "Groups 1 and 3"
    ItemLabels(6) = "Groups 2 and 3"
End Sub
'ViewFormulaBar onAction回调
SubMonitorViewFormulaBar(control As IRibbonControl, pressed As Boolean, ByRef cancelDefault)
    cancelDefault = False 'Restore thefunctionality of the control
    myRibbon.InvalidateControl "G5B1"
End Sub
'CustomTab getVisible回调
Sub getVisibleCustomTab(controlAs IRibbonControl, ByRef CustomTabVisible)
    CustomTabVisible = TypeName(ActiveSheet) ="Worksheet"
End Sub
'gallery1 onAction回调
Sub SelectedPhoto(control AsIRibbonControl, id As String, index As Integer)
    MsgBox "You selected Photo "& index + 1
End Sub
'gallery1 getItemCount回调
Sub getGalleryItemCount(controlAs IRibbonControl, ByRef Count)
    '指定调用getGalleryItemImage过程的次数
    Count = ImageCount
End Sub
'gallery1 getItemImage回调
Sub getGalleryItemImage(controlAs IRibbonControl, index As Integer, ByRef Image)
    '每次调用本程序,index加1
    Set Image = LoadPicture("C:\Photos\"& ImageFilenames(index + 1))
End Sub
'dropDown1 onAction回调
Sub SelectedItem(control AsIRibbonControl, id As String, index As Integer)
    '确定哪个组可见
    VisGrpNm1 = "": VisGrpNm2 =""
    Select Case index
        Case 0
            VisGrpNm1 = "*"
        Case 1
            VisGrpNm1 = "*1"
        Case 2
            VisGrpNm1 = "*2"
            '如果选择第3项则改变Sheet2的外观
            Call ChangeSheet2Appearance
        Case 3
            VisGrpNm1 = "*3"
        Case 4
            VisGrpNm1 = "*1"
            VisGrpNm2 = "*2"
        Case 5
            VisGrpNm1 = "*1"
            VisGrpNm2 = "*3"
        Case 6
            VisGrpNm1 = "*2"
            VisGrpNm2 = "*3"
    End Select
    '使Group1,Group2,和Group3无效
    '执行invalidated,getVisibleGrp
    myRibbon.InvalidateControl"Group1"
    myRibbon.InvalidateControl"Group2"
    myRibbon.InvalidateControl"Group3"
    '更新状态栏
    Application.StatusBar = "Module:" & ItemLabels(index)
End Sub
'dropDown1 getItemCount回调
Sub getDropDownItemCount(control As IRibbonControl, ByRef Count)
    '指定下拉控件中项目总数
    Count = 7
End Sub
'dropDown1 getItemLabel回调
Sub getDropDownItemLabel(control As IRibbonControl, index As Integer, ByRefItemLabel)
    '设置下拉控件中项目标签
    ItemLabel = ItemLabels(index)
    '可替换,如果项目标签被存储在工作表Sheet1单元格区域A1:A7
    '使用下面的代码:
    'ItemLabel =Worksheets("Sheet1").Cells(index + 1, 1).Value
End Sub
' Group1getVisible回调
Sub getVisibleGrp(control AsIRibbonControl, ByRef Enabled)
'基于从下拉控件中选择的项
'隐藏和取消隐藏1,2和3中的某个组
    If control.id Like VisGrpNm1 Or control.idLike VisGrpNm2 Then
        Enabled = True 'Visible
        Enabled = False 'Hidden
    End If
End Sub
Private Sub ChangeSheet2Appearance()
    Application.ScreenUpdating = False
    Sheets("Sheet2").Activate
    With ActiveWindow
        '在页面布局视图中显示当前工作表
        .View = xlPageLayoutView
        '隐藏行和列标题
        .DisplayHeadings = False
        '隐藏网格线
        .DisplayGridlines = False
    End With
    '隐藏公式栏
    Application.DisplayFormulaBar = False
    Application.ScreenUpdating = True
End Sub
' G1B1onAction回调
Sub MacroG1B1(control AsIRibbonControl)
    MsgBox "MacroG1B1"
End Sub
' G1B1getEnabled回调
Sub getEnabledBs(control AsIRibbonControl, ByRef Enabled)
'如果当前工作表具有命名区域MyRange
' G1B1,G2B2,G3B3和G4B3按钮被启用
'在程序中,当在Workbook_SheetActivate事件句柄中
'Ribbon被无效时,本程序被调用
Enabled = RngNameExists(ActiveSheet, "MyRange")
End Sub
Function RngNameExists(ws AsWorksheet, RngName As String) As Boolean
'返回是否在工作表中是否存在指定的命名区域
    Dim rng As Range
    On Error Resume Next
    Set rng = ws.Range(RngName)
    RngNameExists = Err.Number = 0
End Function
' G2B1onAction回调
Sub MacroG2B1(control AsIRibbonControl)
    MsgBox "MacroG2B1"
End Sub
' G2B2onAction回调
Sub MacroG2B2(control AsIRibbonControl)
    MsgBox "MacroG2B2"
End Sub
'G3B1onAction回调
Sub MacroG3B1(control AsIRibbonControl)
    MsgBox "MacroG3B1"
End Sub
' G3B2onAction回调
Sub MacroG3B2(control AsIRibbonControl)
    MsgBox "MacroG3B2"
End Sub
' G3B3onAction回调
Sub MacroG3B3(control AsIRibbonControl)
    MsgBox "MacroG3B3"
End Sub
' G4B1onAction回调
Sub MacroG4B1(control AsIRibbonControl)
    MsgBox "MacroG4B1"
End Sub
' G4B2onAction回调
Sub MacroG4B2(control AsIRibbonControl)
    MsgBox "MacroG4B2"
End Sub
' G4B3onAction回调
Sub MacroG4B3(control AsIRibbonControl)
    MsgBox "MacroG4B3"
End Sub
' G5B1onAction回调
Sub MacroG5B1(control AsIRibbonControl)
    MsgBox "MacroG5B1"
End Sub
' G5B1getEnabled回调
Sub getEnabledG5B1(control AsIRibbonControl, ByRef Enabled)
'如果公式栏可见则启用G5B1按钮
    Enabled = Application.DisplayFormulaBar
End Sub
Sub RemoveUSD(control AsIRibbonControl)
    Dim workRng As Range
    Dim Item As Range
    On Error Resume Next
    Set workRng = Intersect(Selection, _
       Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues))
    If Not workRng Is Nothing Then
        For Each Item In workRng
            If UCase(Left(Item, 3)) ="USD" Then
                Item = Right(Item, Len(Item) -3)
            End If
        Next Item
    End If
End Sub
13. 在ThisWorkbook模块中插入下面的VBA代码：
Private Sub Workbook_Open()
    With Application
    '禁用Workbook_SheetActivate
    '因为myRibbon仍然是Nothing
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    '激活特定的工作表
    Worksheets("Sample").Activate
    '冻洁前3行
    With ActiveWindow
        If .View = xlPageLayoutView Then
            .View = xlNormalView
        End If
        .SplitRow = 3
        .SplitColumn = 0
        .FreezePanes = True
    End With
    '在解除冻洁窗格中设置行50是顶行
    ActiveWindow.ScrollRow = 50
    '给用户的消息
    With Range("A50")
        .Value = "Scroll up to see otherinfo"
        .Font.Bold = True
        .Activate
    End With
'为活动工作表设置滚动区域
'限制在单元格区域A4:H100
    ActiveSheet.ScrollArea ="A4:H100"
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub