如下图所示,一个文件夹内包含了大量文件,现在需要在每个文件前面增加前缀"星光牌-"
为了使代码更具有通用性,更方便大家使用,我们还是采用两步走的方式。
首先,使用以下代码,将该文件夹内的文件名批量提取到当前活动工作表的A列。
Sub GetlWbNames()
Dim strPath As String, strName As String
Dim k As Long
strPath = getStrPath() '获取用户选中文件夹的路径
If strPath = "" Then Exit Sub '如果用户为选择文件夹,则退出程序
Application.ScreenUpdating = False
With ActiveSheet.Columns(1)
.Clear '清空A列
.NumberFormat = "@" '设置文本格式
End With
k = 1
Cells(k, 1) = "目录"
strName = Dir(strPath & "*.*")
Do While strName <> ""
k = k + 1 '计数器
Cells(k, 1) = strName
strName = Dir() '第2次调用dir函数但未带参数
Loop
Application.ScreenUpdating = True
MsgBox "OK"
End Sub
Function getStrPath() As String
Dim strPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
strPath = .SelectedItems(1)
Else '如用户未选中文件夹则退出
Exit Function
End If
End With
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
getStrPath = strPath
End Function
然后,在B列使用函数公式或其它方式,填写A列文件名对应的新名字。本例中B2单元格输入以下公式,并向下复制填充:
="星光牌-"&A2
公式运算结果如下图所示:
最后,复制运行以下代码即可将A列旧的文件名修改为新的文件名。
Sub ChangeNames()
Dim rngData As Range, aData, aRes
Dim i As Long, n As Long, strPath As String
Dim strOldName As String, strNewName As String
Dim strMsg As String
On Error Resume Next '忽略错误使程序继续运行
strPath = getStrPath() '获取文件夹路径
If strPath = "" Then Exit Sub
Set rngData = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
aData = rngData '数据存入数组
ReDim aRes(1 To UBound(aData), 1 To 1) '结果数组
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 2 To UBound(aData) '扣掉标题行遍历数组
If aData(i, 2) <> "" Then
Err.Clear
strOldName = strPath & aData(i, 1) '旧路径名
strNewName = strPath & aData(i, 2) '新路径名
Name strOldName As strNewName '重命名
If Err.Number Then
aRes(i, 1) = "失败"
n = n + 1
Else
aRes(i, 1) = "成功"
End If
End If
Next
Columns(3).ClearContents
aRes(1, 1) = "处理结果"
Range("c1").Resize(UBound(aRes, 1)) = aRes '处理结果写回Excel
Application.ScreenUpdating = True
Application.DisplayAlerts = True
strMsg = "处理完成。"
If n Then strMsg = strMsg & vbCrLf & _
"有" & n & "个文件重命名失败," & _
"需核对新文件名是否有重复。"
MsgBox strMsg
End Sub
Function getStrPath() As String
Dim strPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
strPath = .SelectedItems(1)
Else '如用户为选中文件夹则退出
Exit Function
End If
End With
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
getStrPath = strPath
End Function
第7至第8行代码调用getStrPath函数过程,打开【文件浏览】对话框,允许用户选择的目标文件夹,并获取相关文件的路径。
第9至第10行代码将A:B列的数据源数据存入数组aData。
第11行代码声明一个结果数组aRes,用于存放处理结果信息。
第14至第27行代码遍历数据源数组,把第1列的旧文件名重命名为第2列的新文件名。第20至第25行代码,采用试错法,将处理结果信息写入结果数组。
第28至第30行代码将结果数组写回当前工作表的C列。
第33至第37行代码使用MsgBox语句弹出消息框显示处理结果。
第40至第51行代码是getStrPath函数过程。
技术交流,软件开发,欢迎加微信xwlink1996
作者其他作品:
VBA实战(Excel)(1):提升运行速度
Ribbon第一节:控件大全
HTML实战(1):新建一个HTML
VB.net实战(VSTO):Excel插件的安装与卸载