返回目录：excel表格制作
各位朋友，大家好，由于年终期末事情比较多，所以有很一阵子没发头条了。就是这一阵子忙碌中，我们学院信息中心的一位同事让我帮忙解决了一个年终考核支撑材料高效查看的一种方法，也算是我忙中意外的做的一个原创素材作品吧！今天闲下来，决定将我的这个原创作品分享给各位朋友，希望对你们的工作有所帮助吧！
首先，这位同事给我讲述了他需要的功能效果：点击某一个查看按钮，可以触发展示每个员工有无证书的情况，有无证书的情况完全是智能判断证书文件夹路径下通过检索的形式探测有无该人员的证书图片的问题(当然，这些证书照片是提前由提供者自行以自己姓名命名的图片文件后提交给办公室工作人员的)。
信息技术中心的这位同事也很信任我，所以我不能给人家掉链子吧！所以，我决心实现这个功能。为了实现信息技术中心这位同事的功能要求，我也思考了很久，大致理了一下算法思路：对外部文件夹下图片资源的信息访问存储剖析存储的信息进而判断有无该人员的证书，如果有该人的证书，则显示该人证书名称的提示，没有则说明都不显示有判断的结果即刻生存该人员的证书图元文件信息的全路径超链接，以后办公室工作人员只需点击超链接即可快速预览某个人的证书图片情况实现在Excel中清除所有人的证书显示信息。
为此，我不得不又再一次运用Office高级办公技术的VBA开发技术来实现了。听起来，大家可能有点觉得头疼，但是大家放心，代码的逻辑结构并不复杂，比较简单，且注释也很详尽。下面，大家看了就知道了，哈哈！
一、界面设计
界面比较简单，规划一定数量的单元格区域和两个交互触发的运行宏引导图形按钮。如下图所示
图1 简单的前端界面
二、后台功能实现源码及其注释
模块1内部的代码如下：
Sub Display_Letter_of_Appointment_And_Qualification_Datas() '显示“聘书”和“学历”数据
Dim arr() '定义存储“聘书”超链接文本的数组arr(这里暂时为指定长度，意味着该数组是一个动态的数组)
Dim arr2() '定义存储“学历”超链接文本的数组arr2(这里暂时为指定长度，意味着该数组是一个动态的数组)
'“聘书”图元全路径接信息处理
mypath1 = ThisWorkbook.Path & "聘书*.tif" 'mypath1变量存储当前工作簿路径下“聘书”文件夹下所有包含*.tif图 _
元文件的目录信息
myname1 = Dir(mypath1) '用Dir()目录函数取得指定目录参数文件夹下的第一个图元文件超链接信息存储于临时动态 _
的myname1变量中
Do While myname1 <> "" '依据取得的图元文件超链接全路径信息非空的情况下进行Do While......Loop循环
k = k + 1 'k为存储“聘书”图元全路径接信息条数的累加器，同时将该累加器当前值随即作为“聘书”超链接信息存储 _
的动态数组的上界
ReDim Preserve arr(1 To k) 'ReDim Preserve的作用是重新分配数组空间 默认情况下重新分配空间后数组内容都会清 _
空,加上preserve后可以保留原来的数据在进行动态分配空间。
arr(k) = myname1 '同时，将当前取得的图元全路径接信息(全路径超链接信息)立即存储于“聘书”数据信息存储的数组 _
arr中
myname1 = Dir() '若第二次进入循环调用Dir函数且不带任何参数时，则函数将返回同一目录下的下一个*.tif文件。
Loop
'“学历”图元全路径接信息处理(以下的的源代码解释同上)
mypath2 = ThisWorkbook.Path & "学历*.tif"
myname2 = Dir(mypath2)
Do While myname2 <> ""
k2 = k2 + 1
ReDim Preserve arr2(1 To k2)
arr2(k2) = myname2
myname2 = Dir()
Loop
'以With子句的形式简化处理“聘书”和“学历”数据在Excel工作表中的显示
With Sheets("Sheet1")
max_row = .[A65536].End(xlUp).Row '由A列的最后一个元素A65536为基准，向上回溯的方式取得最大有效数据的行号存 _
于max_row中
'用For Each循环的方式实现“聘书”和“学历”数据的显示
For Each rg In .Range("A2:A" & max_row) 'rg为范围.Range("A2:A" & max_row)中的一个循环变化的单元格变量
'对某人“聘书”图元信息作超链接的生成操作
For i1 = 1 To UBound(arr) '用UBound方法取得数组arr的上界下标
If InStr(arr(i1), rg) Then '如果当前的“聘书”图元全路径接信息中包含有rg单元格的值，则作如下处理
rg.Offset(0, 1) = "聘书" '以rg单元格为基准进行偏移0行1列后形成的新单元格的值为“聘书”二字
'以下以超链接添加形式(.Hyperlinks.Add)添加某人的“聘书”图元全路径接信息：链接的文本为 _
Anchor:=rg.Offset(0, 1)，地址为Address:=ThisWorkbook.Path & "聘书" & rg & ".tif"
.Hyperlinks.Add Anchor:=rg.Offset(0, 1), Address:=ThisWorkbook.Path & "聘书" & rg & ".tif"
End If
Next
'对某人“学历”图元信息作超链接的生成操作(解释类似上面)
For i2 = 1 To UBound(arr2)
If InStr(arr2(i2), rg) Then
rg.Offset(0, 2) = "学历"
.Hyperlinks.Add Anchor:=rg.Offset(0, 2), Address:=ThisWorkbook.Path & "学历" & rg & ".tif"
End If
Next
Next
End With
End Sub
Sub Erse_Letter_of_Appointment_And_Qualification_Datas() '清除“聘书”和“学历”数据
Dim Rg_Effect_Datas As Range '定义一个有效数据区域的范围变量Rg_Effect_Datas
With Sheets("Sheet1")
max_row = .[A65536].End(xlUp).Row '由A列的最后一个元素A65536为基准，向上回溯的方式取得最大有效数据的行号存 _
于max_row中
Set Rg_Effect_Datas = .Range("B2:F" & max_row)
cta = 0
For i = 1 To Rg_Effect_Datas.Count
If Len(Trim(Rg_Effect_Datas(i))) = 0 Then cta = cta + 1
Next
If cta = Rg_Effect_Datas.Count Then '如果全为空单元格，则禁止清除
MsgBox "已经无数据，清除聘书、学历数据信息被禁止！", vbInformation, "提示"
Else '否有非空单元格，执行数据清除
Rg_Effect_Datas.ClearContents
MsgBox "清除聘书、学历数据展示信息成功！", vbInformation, "提示"
End If
End With
End Sub
三、快速浏览证书图片测测试
(一)执行按钮<显示“聘书”和“学历”数据>后的效果。如下图所示
图2 显示人员有无证书的信息展示
(二)随机点击某个人的证书名称可以看到该人员的证书图片的浏览。如下图所示
图3 点击某人的证书信息浏览证书-1
图4 点击某人的证书信息浏览证书-2
(三)点击<清除“聘书”和“学历”数据>按钮，将清除所有人员证书信息的显示。效果如下图所示
图5 清除所有人的证书类别名称显示信息
如果没有数据，再次清除，会提示无数据，清除操作被禁止的提示。如下图所示
图6 无数据清除操作被禁止
四、技术小结
(一)用Dir()函数+Do While…Loop循环的形式巧妙快速载入外部图元信息到动态数组存储
(二)随时可变长度的动态数组的定义格式形如：ReDim Preserve arr(1 To k)，其中k是动态变化的，而加上preserve后可以保留原来的数据在进行动态分配空间
(三)给某个人有证书的类别名称信息展示后加超链接的方法如下：工作表.Hyperlinks.Add Anchor:=链接的文字, Address:=外部图元全路径信息
好了，我们今天的干货技术就分享到这里，希望对各位工作能够带来便利！
最后，非常感谢各位的长期关注(头条号：跟我学Office高级办公)、推广和点评，再一次谢谢大家！