[已解决]【求高手帮忙合并代码】批量重命名文件名+获取文件的创建时间

yvhanym · 发表于 2012-5-27 22:27

有一大批文件需要统一重新命名，就是在所有文件名称前面统一加上文件的信息例如：“创建日期，【2012年05月】文件名.xls"。
希望在一个Excel表格里面有两个按钮（【查找】、【修改】）
1、点击【查找】以后实现：
从A2开始，A列显示这个表格所在目录下（包括文件下里面的文件）所有文件的名称，从B2开始，B列显示文件的创建时间，从C2开始，显示文件的修改时间等文件信息求……

2、再点击【修改】
那么文件能修改为E列对应的新文件名称。（前提是从E2开始，E列有对应的名称）

已经有相关代码，求高手帮忙修改，感谢。

批改文件名的VB代码为：

Dim fs, f, f1, fc, objxls
Dim filename() As Variant
Dim fullfilename() As Variant
Dim newfullfilename() As Variant
Dim namefilter() As Variant
Dim i%, n%
Sub getnames()
Dim error
On Error Resume Next
Set objxls = CreateObject("Excel.application")
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(ActiveWorkbook.Path)
Set fc = f.Files
n = 0
For Each f1 In fc
ReDim Preserve filename(n)
ReDim Preserve fullfilename(n)
ReDim Preserve namefilter(n)
fullfilename(n) = f1
namefilter(n) = Right(f1, Len(f1) - InStrRev(f1, "."))
filename(n) = Mid(f1, InStrRev(f1, "") + 1, Len(f1) - InStrRev(f1, "") - Len(namefilter(n)) - 1)
n = n + 1
Next
Range("C2").Resize(n) = Application.Transpose(filename)
Range("E2").Resize(n) = Application.Transpose(fullfilename)
End Sub
Sub changenames()
Dim error
On Error Resume Next
n = Range("E65536").End(xlUp).Row - 1
ReDim newfullfilename(n - 1)
ReDim filename(n - 1)
ReDim fullfilename(n - 1)
For i = 0 To n - 1
fullfilename(i) = Range("E" & 2 + i)
filename(i) = Range("D" & 2 + i)
If Range("D" & 2 + i) = "" Then GoTo 200
newfullfilename(i) = ActiveWorkbook.Path & "" & filename(i) & "." & Right(fullfilename(i), Len(fullfilename(i)) - InStrRev(fullfilename(i), "."))
Name fullfilename(i) As newfullfilename(i)
200
Next
'Range("F2").Resize(n) = Application.Transpose(newfullfilename)
End Sub

复制代码

查找文件创建日期的VB代码为：

Option Explicit
Sub 提取文件信息()
Dim arr(1 To 10000) As String
Dim f, i, k, f2, f3, x
Dim arr1(1 To 100000, 1 To 6) As String, q As Integer
Dim fso As Object, myfile As Object
arr(1) = ThisWorkbook.Path & ""
i = 1: k = 1
Do While i < UBound(arr)
If arr(i) = "" Then Exit Do
f = Dir(arr(i), vbDirectory)
Do
If InStr(f, ".") = 0 And f <> "" Then
k = k + 1
arr(k) = arr(i) & f & ""
End If
f = Dir
Loop Until f = ""
i = i + 1
Loop
'*******下面是提取各个文件夹的文件***
Set fso = CreateObject("Scripting.FileSystemObject")
For x = 1 To UBound(arr)
If arr(x) = "" Then Exit For
f3 = Dir(arr(x) & "*.*")
Do While f3 <> ""
q = q + 1
arr1(q, 6) = arr(x) & f3
Set myfile = fso.GetFile(arr1(q, 6))
arr1(q, 1) = f3
arr1(q, 2) = myfile.Size
arr1(q, 3) = myfile.DateCreated
arr1(q, 4) = myfile.DateLastModified
arr1(q, 5) = myfile.DateLastAccessed
f3 = Dir
Loop
Next x
Range("a2").Resize(1000, 6) = ""
Range("a2").Resize(q, 6) = arr1
End Sub

复制代码

最佳答案

月排行榜 / 总排行榜

zjdh

2012-5-28 10:39

本帖最后由 zjdh 于 2012-5-28 10:47 编辑

批量修改文件名3.rar (18.81 KB, 下载次数: 113)

那么的帅 · 发表于 2012-5-28 00:00

提供数据附件。

zjdh · 发表于 2012-5-28 10:39

本帖最后由 zjdh 于 2012-5-28 10:47 编辑

批量修改文件名3.rar (18.81 KB, 下载次数: 113)

hai0625 · 发表于 2013-5-21 21:08

zjdh 发表于 2012-5-28 10:39

非常感谢您的代码，正需要批量重命名文件名。
有2点小建议不知道能否实现：
1、现在重命名结束以后，会出一个提示框，能否改成：重命名结束后，直接用资源管理器打开文件所在路径。
2、如果文件格式都一样，新文件名之中有重复的名字，那么只有一个文件会被重命名，能否在重命名之前进行判断，如果发现有新文件名有一种或多种相同的，给出提示信息，询问是否强行改名，如果是，改名后用资源管理器打开，如果否，则不进行改名。

再次感谢您的帮助！！

zjdh · 发表于 2013-5-30 10:38

问题1可以解决。
问题2 系统不允许相同名称文件强制存在，所以只给一个提示。

批量修改文件名4.rar (17.03 KB, 下载次数: 57)

hai0625 · 发表于 2013-5-30 23:59

zjdh 发表于 2013-5-30 10:38
问题1可以解决。
问题2 系统不允许相同名称文件强制存在，所以只给一个提示。

对于问题2，用新VBA又做了一些测试，又有了一些想法：

如果新文件名和原文件名相同，则不进行改名，计数器A+1。
如果新文件名和原文件名不同，则进行改名，计数器B+1。
最后给出提示信息，”A个文件未改名，B个文件改名成功“。
如果新文件名存在相同的情况，比较原文件名的格式是否相同，如果相同，提示“无法改名，请确保新文件名不同”；如果格式不同，则进行改名。
在原文件名格式相同的情况下，新文件名相同可能出现几组相同的情况，比如说2个AA，两个BB，只要检测出有一组相同，即无法满足条件。

对于批量修改文件名的工具来说，如果遇到新文件名都是自定义且无规律的情况，此VBA会相当有用。上述思考仅是在改名过程中进行一个检查及提示，如果方便，希望能更新代码。

非常感谢！

fangkaina2 · 发表于 2014-9-27 15:40

zjdh 发表于 2012-5-28 10:39

非常感谢，帮我大忙了，呵呵

		自动登录	找回密码
密码			注册

[已解决]【求高手帮忙合并代码】批量重命名文件名+获取文件的创建时间

相关帖子