求助 excel 批量重命名

350977106

多个文件夹内含有恢复过来的excel文件，命名为系统命名，如file001,file002等序列文件，想通过vba进行重命名。
1，以对话框的方式打开需重命名的文件夹。
2，文件以第一张工作表名称，+第一张工作表A4单元格的值命名。
3，如有重复文件，则在文件名称后，加上序号。如附件里file012命名为“岗位聘任尚03”
谢谢各位老师的真挚帮助！！！

daxushen

表达目的不明确，比如file003文件，是命名为附件1单位？file005，中的第一张表（附件1）还被合并单元格了，命名还附件1单位？？？

350977106

daxushen 发表于 2021-6-17 15:04
表达目的不明确，比如file003文件，是命名为附件1单位？file005，中的第一张表（附件1）还被合并单元格了， ...

A4单元格值为空时，忽略。就命名为附件1+序号，绝大多数表格为file012样式，我只是抽出几张表做个例子。
如老师能帮忙做到，之后我可以根据您的答案适当修改，再对file003,file005类文件进行再改名。谢谢！！！

350977106

多数表格是这个样式 的，A4单元格为空，合并，取不到值则忽略

daxushen

350977106 发表于 2021-6-17 15:32
多数表格是这个样式 的，A4单元格为空，合并，取不到值则忽略

像file005那种文件直接舍弃？

350977106

daxushen 发表于 2021-6-17 15:37
像file005那种文件直接舍弃？

也可以，谢谢！！！

daxushen

https://mail.qq.com/cgi-bin/ftnE ... d&code=f4386316


可以下载使用，仅限于你这类型的Excel文档，使用前请备份，以免出错。

350977106

daxushen 发表于 2021-6-17 18:35
https://mail.qq.com/cgi-bin/ftnExs_download?k=243433386e0d5cc9cdbb66bc103303195002500f500000024b0500 ...

谢谢老师的帮助，但我电脑使用的是32系统，软件打不开。老师能否提供一下源码，不甚感激！！！
或者帮忙把下面一段代码给改良一下。这段代码是我从网上搜的，做了一些改变，中间部分能达到要求。
老师能否把 1 ，Const PathName = "e:\ssx\Excel"红字部分改成对话框方式（像打开我和文档一样），2 ，增加重复文件判断，Timer 改成序号形式。
谢谢！！！

'如何操作让工作薄和本工作薄中第一个工作表名称一致
Sub Renametest()
On Error Resume Next
Const PathName = "e:\ssx\Excel" '此处更改为实际文件夹路径
Dim WorkPath As Object
Dim Fso As Object
Dim xlFile As Object
Dim WB As Workbook
Dim ShName As String
Dim mycell As String
Dim ExtName As String
Dim n As Long
Set Fso = CreateObject("scripting.filesystemobject")
Set WorkPath = Fso.GetFolder(PathName)
For Each xlFile In WorkPath.Files
If UCase(Right(xlFile.Name, 3)) = "XLS" Or UCase(Right(xlFile.Name, 4)) = "XLSX" _
Or UCase(Right(xlFile.Name, 4)) = "XLSM" Then
Set WB = Workbooks.Open(PathName & "\" & xlFile.Name)
ShName = WB.Sheets(1).Name
mycell = WB.Sheets(1).Cells(4, 1).Value
ShName = ShName & mycell & Timer  '工作簿名称为工作表1名称+工作表1单元格（4，1）名称+时间

WB.Close
If UCase(Right(xlFile.Name, 3)) = "XLS" Then
ExtName = ".xls"
ElseIf UCase(Right(xlFile.Name, 4)) = "XLSX" Then
ExtName = ".xlsx"
ElseIf UCase(Right(xlFile.Name, 4)) = "XLSM" Then
ExtName = ".xlsm"
End If
xlFile.Name = ShName & ExtName

End If
Next
End Sub

350977106

谢谢老师的诚挚帮助！！！但我是32位系统，软件提示打不开。
老师能否帮我把下面一段代码修改一下，以完全达到我的要求。
1、指定文件夹改成对话框形式
2、对重复文件进行判断，增加序号，而不是采用Timer方式，虽然能对所有文件重命名，但文件名太长。
3，因为是恢复的文件，有的文件能重命名，但打不开，或是乱码，能不能用代码将这些文件命名时标记出来
网上搜的代码，我已经改动了一部分
'如何操作让工作薄和本工作薄中第一个工作表名称一致
Sub Renametest()
On Error Resume Next
Const PathName = "e:\ssx\Excel" '此处更改为实际文件夹路径
Dim WorkPath As Object
Dim Fso As Object
Dim xlFile As Object
Dim WB As Workbook
Dim ShName As String
Dim mycell As String
Dim ExtName As String
Set Fso = CreateObject("scripting.filesystemobject")
Set WorkPath = Fso.GetFolder(PathName)
For Each xlFile In WorkPath.Files
If UCase(Right(xlFile.Name, 3)) = "XLS" Or UCase(Right(xlFile.Name, 4)) = "XLSX" _
Or UCase(Right(xlFile.Name, 4)) = "XLSM" Then
Set WB = Workbooks.Open(PathName & "\" & xlFile.Name)
ShName = WB.Sheets(1).Name
mycell = WB.Sheets(1).Cells(4, 1).Value
ShName = ShName & mycell & Timer  '工作簿名称为工作表1名称+工作表1单元格（4，1）名称+时间

WB.Close
If UCase(Right(xlFile.Name, 3)) = "XLS" Then
ExtName = ".xls"
ElseIf UCase(Right(xlFile.Name, 4)) = "XLSX" Then
ExtName = ".xlsx"
ElseIf UCase(Right(xlFile.Name, 4)) = "XLSM" Then
ExtName = ".xlsm"
End If
xlFile.Name = ShName & ExtName

End If
Next
End Sub

老师帮看一下，谢谢！！！

daxushen

350977106 发表于 2021-6-18 09:52
谢谢老师的帮助，但我电脑使用的是32系统，软件打不开。老师能否提供一下源码，不甚感激！！！
或者帮忙 ...

我那是Python写的，VBA目前不太熟悉，正在学习中。