1.如何用VBA快速修改文件名
Sub 批量改名()
Dim FolderName As String, wbName As String, cValue As Variant
Dim wbList() As String, wbCount As Integer, i As Integer, str As String, exname As String
FolderName = "G:\360data\重要数据\桌面\新建文件夹" '文件夹路径
'创建文件夹中工作簿列表
wbCount = 0
wbName = Dir(FolderName & "\" & "*.xls*")
While wbName <> ""
wbCount = wbCount + 1
ReDim Preserve wbList(1 To wbCount)
wbList(wbCount) = wbName
wbName = Dir
Wend
If wbCount = 0 Then Exit Sub
'从每个工作簿中获取数据
For i = 1 To wbCount
cValue = GetInfoFromClosedFile(FolderName, wbList(i), "sheet1", "a1")
exname = Mid(wbList(i), InStr(wbList(i), "."))
Name FolderName & "\" & wbList(i) As FolderName & "\" & cValue & exname
On Error Resume Next
Name FolderName & "\" & wbList(i) As FolderName & "\" & cValue & i & exname
Next i
End Sub
'====================从未打开表中获取信息===========================
Private Function GetInfoFromClosedFile(ByVal wbPath As String, _
wbName As String, wsName As String, cellRef As String) As Variant
Dim arg As String
GetInfoFromClosedFile = ""
If Right(wbPath, 1) <> "\" Then wbPath = wbPath & "\"
If Dir(wbPath & "\" & wbName) = "" Then Exit Function
arg = "'" & wbPath & "[" & wbName & "]" & _
wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
r = 0
On Error Resume Next
GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function
2.求EXCEL VBA批量修改文件名的代码示例
办公室有个批量更改照片的 占个位置 明天上班再贴 半夜懒重写了。
目标:为学员照相 导入电脑并批量修改为学号加姓名
1、首先建立一个EXCEL表 其中第一个工作薄名称为照相顺序表 如下图
Sub 照片重命名()
If MsgBox("程序将重命名与本工作薄同目录下的所有照片文件,确认这样做么?", vbYesNo) 6 Then
Exit Sub
End If
Dim oldname As String '旧文件名变量oldname
Dim newname As String '新文件名变量newname
Dim photopath As String '路径变量photopath
Dim nophoto As String '错误提示变量nophoto
Dim i As Integer '循环变量i
photopath = ThisWorkbook.Path '为要修改的文件名路径复制为当前excel文件的路径
For i = 2 To Worksheets("照相顺序表").Range("a65536").End(xlUp).Row '开始循环 从“照相顺序表”工作薄的a2单元格开始
'为新文件名变量赋值为路径变量& \ & 照相顺序表工作薄中的a2&b2单元格内容加上扩展名.jpg
newname = photopath & "\" & Worksheets("照相顺序表").Cells(i, 1).Text & Worksheets("照相顺序表").Cells(i, 2).Text & ".jpg"
'为旧文件名变量赋值为路径变量& \ & 照相顺序表工作薄中的c2单元格内容&扩展名.jpg
oldname = photopath & "\" & Worksheets("照相顺序表").Cells(i, 3).Text & ".jpg"
'判断旧文件名是否在当前目录存在
If Dir(oldname) "" Then
Name oldname As newname '存在则改名
Else
nophoto = nophoto & Chr(10) & oldname'不存在则将其赋值给错误提示变量并以回车分割累加
End If
Next i
If nophoto "" Then
MsgBox nophoto & Chr(10) & "图片不存在" '存在错误提示则弹出错误提示框
End If
End Sub
备注是刚添加的 希望有所帮助,另外求分谢谢。
3.VBA怎样实现 批量选择word文档读取其文件名并填表 的功能
Sub Test()
Dim f, n, x, wb, fName
On Error Resume Next
Cells.Clear
'打开文件(可多选)
f = Application.GetOpenFilename("Word文件,*.docm,", 1, "选择文件", MultiSelect:=True)
'遍历每个选择的文件
For x = 1 To UBound(f)
sFile = f(x)
'取文件名,并赋值给单元格
n = Len(sFile) - InStrRev(sFile, "\")
fName = Right(sFile, n)
Cells(x, 1) = Left(fName, InStr(fName, " ") - 1) '取1到空格前的字符
'Cells(x, 1) = Left(fname, 9) '取文件名的前9个字符
Cells(x, 2) = Mid(fName, InStr(fName, " ") + 1, Len(fName) - InStr(fName, ".") + 1) '取空格后到点之前的字符
'Cells(x, 2) = Mid(fName, 10, Len(fName) - InStr(fName, ".") + 1) '从10开始取到点之前的字符
Next x
End Sub
4.用vba打开word模板并修改后保存
1、打开Word文件的 VBA编辑器,快捷键 Alt+F11,右击【ThisDocument】-》 【插入模块】; 用VBA代码设置Word自动保存的步骤 2、双击刚才插入的【模块1】,添加如下代码: Sub 自动备份() Dim NewTime NewTime = Now + TimeValue(“00:05:10”) Dim myPath$, myName$ myPath = ActiveDocument.Path myName = Left$(ActiveDocument.Name, Len(ActiveDocument.Name) - 4) ChangeFileOpenDirectory myPath ActiveDocument.SaveAs FileName:=myName & “_temp.doc”, ReadOnlyRecommended:=True ActiveDocument.SaveAs FileName:=myName & “.doc”, ReadOnlyRecommended:=False Application.OnTime NewTime, “自动备份” CreateObject(“Wscript.shell”).popup “备份成功,备份文件名为:” & myName & “_temp.doc”, 2, “提示!2秒后自动关闭!” End Sub 用VBA代码设置Word自动保存的步骤 用VBA代码设置Word自动保存的步骤 3、双击【ThisDocument】并在其中 添加如下代码: Private Sub Document_Open() Call 自动备份 End Sub 用VBA代码设置Word自动保存的步骤 4、默认自动备份时间为5min,如要调整请修改【模块1】中一句代码:如图中红框所示: 时间格式为:HH : mm : ss 用VBA代码设置Word自动保存的步骤 5、保存代码及文件,且关闭word并重新打开,重新打开点击【选项】-》 【启用此内容】,如图: 用VBA代码设置Word自动保存的步骤 6、默认备份文件名为:【原文件名_temp,Lee.doc】且为只读,提示对话框2s后自动关闭。
备份效果显示如下: 。
5.利用VBA批量重置指定格式文件名
在任意Word文档中新建一宏,将下列代码粘贴到此宏中,执行此宏即可完成任务'以下是需要复制的vba代码:On Error Resume Next:'本例代码将指定文件夹中的指定类型文件按 A+4位顺序号 重命名Dim i As IntegerDim Str1 As StringDim PathStr As StringDim FileTypeStr As StringDim NewName As StringDim ObjfsoDim ObjfoldersPathStr = InputBox("请输入需要处理的文件所在的文件夹路径:" & vbCrLf & "如:d:\下载图片", "文件夹名称")If PathStr = "" Or Dir(PathStr, vbDirectory) = "" Then MsgBox "文件夹输入错误,操作被取消!", vbInformation, "提示" Exit SubEnd IfIf Right(PathStr, 1) = "\" Then PathStr = Left(PathStr, Len(PathStr))End IfFileTypeStr = InputBox("请输入需要处理的文件类型:" & vbCrLf & "如:jpg 或者 png 等", "文件类型", "jpg")If Len(FileTypeStr) <> 3 Then MsgBox "文件类型输入错误,操作被取消!", vbInformation, "提示" Exit SubEnd IfSet Objfso = CreateObject("Scripting.FileSystemObject")Set Objfolders = Objfso.GetFolder(PathStr)FileTypeStr = "." & LCase(FileTypeStr)For Each objFile In Objfolders.Files Str1 = objFile.Name Str1 = LCase(Str1) '过滤格式进行重命名 If InStr(1, Str1, FileTypeStr) <> 0 Then i = i + 1 '格式化新文件名 NewName = PathStr + "\" & "A" & Format(i, "0000") & FileTypeStr '与新文件同名将被忽略 Objfso.MoveFile objFile, NewName End IfNextSet Objfolders = NothingSet Objfso = NothingMsgBox "重命名过程执行完毕!", vbInformation, "提示"i = Shell("explorer.exe " & PathStr, vbNormalFocus)。
转载请注明出处51数据库 » vba修改word文件名