【分享成果 ， 随喜正能量】其实每一朵花,都有它自己的生命 。当花儿枯萎的时候,就是它生命终结的时候，而它的种子 ， 就是它生命的延续，在这个世界上继续承受风，经受雨面对另一个轮回 。。
《VBA高级应用30例》，是我推出的第十套教程 ， 教程是专门针对高级学员在学习VBA过程中提高路途上的案例展开 ， 这套教程案例与理论结合，紧贴“实战”，并做“战术总结”，以便大家能很好的应用 。教程的目的是要求大家在实际工作中分发VBA程序，写好的程序可以升级 。本套教程共三册三十个专题，今日内容是第一个专题：创建加载项的母工作簿及写入代码
应用1 在EXCEL中构建加载项
Excel是一个功能非常强大的应用程序，具有数千个选项和功能，可帮助我们构建模型、报告和数据分析 。但是，在我们日常工作中往往也会需要一些额外的功能，这就需要我们使用VBA来扩充 。本文将给大家展示如何创建一个小型实用程序，我将概述来创建外接程序的所有步骤 。这些步骤的使用可以帮助大家构建自己的自定义应用 。2 创建母工作簿
Excel外接程序只不过是保存为外接程序的工作簿 。我们可以直接编辑外接程序，并将其与任何其他工作簿一样保存，其实我更喜欢在通常的Excel工作簿中进行所有开发，然后在完成后将开发工作簿另存为外接程序（xlma文件） 。因此 ， 打开一个工作簿，下面的截图我同时打开了VBA编辑器，只显示了对象浏览器：
3 建立工作模块
此工具的基础是插入和更新名为ToC的表工作表 。因为我选择在每个工作表条目旁边有一个注释行，所以我们需要临时存储这些注释 ， 并（在刷新ToC后）将它们添加回它们所属的位置：以及它们关联的工作表名称 。首先，如下截图，我们插入一个模块：
并在“属性”窗口中更改模块名称：（如果你的VBE界面没有属性窗口，可以按下F4键即可）
4 写入功能的代码
双击这个模块，写入下面的代码：Sub UpdateTOC()
Dim oSh As Object
Dim oToc As Worksheet
Dim vRemarks As Variant
Dim lCt As Long
Dim lRow As Long
Dim lCalc As Long
Dim bUpdate As Boolean
'分别提取工作表即时状态中的屏幕更新及是否为自动计算的状态并重新设置
bUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
lCalc = Application.Calculation
Application.Calculation = xlCalculationManual
【创建加载项的母工作簿及写入代码】'检查工作表ToC是否存在，如果不存在 ， 请插入一个
If Not IsIn(Worksheets, "ToC") Then
With Worksheets.Add(Worksheets(1))
.Name = "ToC"
End With
Set oToc = Worksheets("ToC")
'设置工作表网格线、行标题和列标题的显示效果
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHeadings = False
Else
Set oToc = Worksheets("ToC")
'如果有一个现有的ToC ， 将整个表存储在一个数组中，这样我们以后就可以使用了
vRemarks = oToc.ListObjects(1).DataBodyRange
End If
'检查ToC表上的表格，如果缺少，请插入一个表格
If oToc.ListObjects.Count = 0 Then
oToc.Range("C2").Valuehttps://www.itzhengshu.com/excel/= "https://www.itzhengshu.com/excel/工作表名称"
oToc.Range("D2").Valuehttps://www.itzhengshu.com/excel/= "https://www.itzhengshu.com/excel/链接"
oToc.Range("E2").Valuehttps://www.itzhengshu.com/excel/= "https://www.itzhengshu.com/excel/备注"
oToc.ListObjects.Add xlSrcRange, oToc.Range("C2:E2"), , xlYes
End If
On Error Resume Next
'清空表格
'如果表已为空，则忽略错误
oToc.ListObjects(1).DataBodyRange.Rows.Delete
'在工作表集合中获取工作表的名称，链接 ， 及备注
For Each oSh In Sheets
If oSh.Visible = xlSheetVisible Then
lRow = lRow1
oToc.Range("C2").Offset(lRow).Value = https://www.itzhengshu.com/excel/oSh.Name
'建立对应工作表A1单元格的链接
oToc.Range("C2").Offset(lRow, 1).FormulaR1C1 = "=HYPERLINK(""#'""&RC[-1]&""'!A1"",RC[-1])"
oToc.Range("C2").Offset(lRow, 2).Valuehttps://www.itzhengshu.com/excel/= ""
'恢复此工作表中对于原工作表的注释
For lCt = LBound(vRemarks, 1) To UBound(vRemarks, 1)
If vRemarks(lCt, 1) = oSh.Name Then
oToc.Range("C2").Offset(lRow, 2).Value = https://www.itzhengshu.com/excel/vRemarks(lCt, 3)
Exit For
End If
Next
End If
Next
'筛选状态
oToc.ListObjects(1).Range.EntireColumn.AutoFit
'恢复自动计算及屏幕更新
Application.Calculation = lCalc
Application.ScreenUpdating = bUpdate
End Sub
代码的截图：
代码的讲解：由于在代码部分我做了比较详细的注释，下面我仅就重点部分说明 。
① 需要注意的是对于工作表原注释的恢复部分 ， 我们是利用了vRemarks = oToc.ListObjects(1).DataBodyRange 获得原工作表的注释，以便在更新后在下面的代码中恢复数据：
For lCt = LBound(vRemarks, 1) To UBound(vRemarks, 1)
If vRemarks(lCt, 1) = oSh.Name Then
oToc.Range("C2").Offset(lRow, 2).Value = https://www.itzhengshu.com/excel/vRemarks(lCt, 3)
Exit For
End If
Next
[待续]
- 本讲内容参考程序文件：高级应用01.xlsm
- 第三方应用软件：OfficeRibbonXEditor-NETFramework-Installer.EXE
- 实现的外接应用程序：mynzSheetTools.xlma
我20多年的VBA实践经验，全部浓缩在下面的各个教程中：
【分享成果，随喜正能量】山高水长 ， 怕什么来不及，慌什么到不了，天顺其然 ， 地顺其性，人顺其变，一切都是刚刚好 。平和地接纳，不屈地奋斗，坚定地前行，如一泓清泉 ， 静水流深，看似力量并不汹涌澎湃，却能磋磨岩石锋利的尖角，涤荡水中的混沌的杂质 ， 把困难揉碎，长成属于自己的力量 。。