楼主
kevinchengcw |
Q: 如何利用vba代码实现根据规则的文件名更新文件列表及链接、批注等内容？
A: 本例中文件名命名规则为：字段1.字段2.版本.pdf，基于如此规则的命名，在重建列表时即可轻易的实现对应字段分割及版本号检查工作。
示例代码如下：
- Sub test()
- Dim FN$, Arr, N%, Dic, Rng As Range, Str$, Str2$, hasComment As Boolean
- Set Dic = CreateObject("scripting.dictionary") '创建字典项目
- With Sheet1 '对操作页进行操作
- If .Cells(.Rows.Count, 1).End(3).Row > 3 Then '如果操作页的A列有原始数据存在（即第4行开始向下有数据存在），则
- For Each Rng In .Range(.[a4], .Cells(.Rows.Count, 1).End(3)) '循环A列数据区各单元格
- If Rng <> "" Then '如果当前循环到的单元格不为空（容错作用），则
- With Rng
- If .Offset(0, 4).Comment Is Nothing Then '判断D列当前行是否有批注存在，如果没有则
- hasComment = False '判断有无批注的逻辑变量值为假
- Str2 = "" '记录批注文本的字符串变量为空
- Else
- hasComment = True '判断有无批注的逻辑变量值为真
- Str2 = .Offset(0, 4).Comment.Text '记录批注文本的变量赋值为批注的内容
- End If
- Dic.Add UCase(.Value) & "." & UCase(.Offset(0, 1).Value), Replace(.Offset(0, 2).Value, "A/", "") & vbTab & .Offset(0, 4).Text & vbTab & UCase(CStr(hasComment)) & vbTab & Str2 '添加对应的字典项（item项格式：版本去除字母后的数值+D列的文本内容+判断注释存在的逻辑变量的值的文本+记录注释文本的变量的值）
- End With
- End If
- Next Rng
- With .Range(.[a4], .Cells(.Rows.Count, 1).End(3).Offset(0, 6)) '当有原始数据时清除原始数据中的内容（含文本及批注）
- .ClearContents
- .ClearComments
- End With
- End If
- FN = Dir(ThisWorkbook.Path & "\*.pdf") '查找当前工作簿文件夹下的pdf文件
- N = 4 '初始化数据起始行的行号值变量
- Do While FN <> "" '当文件名不为空时继续循环
- Arr = Split(UCase(FN), ".") '将文件名全部变成大写后依"."分割成数段放入数组中
- Str = Arr(0) & "." & Arr(1) '组合1、2段，方便同字典中的项目进行对比
- If Dic.exists(Str) Then '如果存在该字典项目，则
- .Cells(N, 1) = Arr(0) '向数据区A列当前行写入文件名1段内空
- .Hyperlinks.Add .Cells(N, 2), ThisWorkbook.Path & "\" & FN, "", Arr(1), Arr(1) '向B列当前行写入链接文本
- .Cells(N, 3) = Replace(Arr(2), "A", "A/") '向C列当前行写入变换后的版本号文本
- If Val(Replace(Arr(2), "A", "")) > Val(Split(Dic(Str), vbTab)(0)) Then '判断当前版本号是否大于旧的版本号，如果大于则
- .Cells(N, 5) = Format(Date, "yyyy-m-d") 'E列当前行写入当前日期
- If UCase(Split(Dic(Str), vbTab)(2)) = "TRUE" Then '如果原始数据该单元格有批注，则
- .Cells(N, 5).AddComment Split(Dic(Str), vbTab)(3) & vbNewLine & Format(Date, "yyyy-m-d") & "-" & .Cells(N, 3).Value '将原有批注内容与新的版本信息串接后作为新的批注插入E列当前行
- Else '如果原数据没有批注，则
- .Cells(N, 5).AddComment Split(Dic(Str), vbTab)(1) & "-A/" & Split(Dic(Str), vbTab)(0) & vbNewLine & Format(Date, "yyyy-m-d") & "-" & .Cells(N, 3).Value '将原始数据的日期及版本及当前日期及版本作为批注插入
- End If
- Else '如果版本未更新，则
- .Cells(N, 5) = Split(Dic(Str), vbTab)(1) 'E列当前行写入原始数据的日期
- If UCase(Split(Dic(Str), vbTab)(2)) = "TRUE" Then .Cells(N, 5).AddComment Split(Dic(Str), vbTab)(3) '判断是否原始数据有批注，有则同样插入原始数据中的批注
- End If
- Else '如果字典中不存在该项目，则全新添加
- .Cells(N, 1) = Arr(0)
- .Hyperlinks.Add .Cells(N, 2), ThisWorkbook.Path & "\" & FN, "", Arr(1), Arr(1)
- .Cells(N, 3) = Replace(Arr(2), "A", "A/")
- .Cells(N, 5) = Format(Date, "yyyy-m-d")
- End If
- N = N + 1 '下移一行
- FN = Dir '下一个文件
- Loop
- End With
- Set Dic = Nothing '清空字典项目
- End Sub
附示例文件。
 文件列表更新示例.rar
|