一个个性化的重命名工具
本例是个人用到的东西,备份到此,有时用到
工作中我用到的重命名
------------------------------
有如下的扫描文件
SKM_C36821111117540_0001.pdf |
---|
SKM_C36821111117540_0002.pdf |
SKM_C36821111117540_0003.pdf |
要把它们重命名为:
小龙女-新增.pdf |
---|
杨过-新增.pdf |
郭大侠-新增.pdf |
--------------------------------------
用手工做呢,几个还可以如果有100多个,那就。。。。
用网上的重命名工具,不合适。
想想还是自己做一个吧。
【准备界面】
【使用方法】
ABC三列可以点击【获取文件】按键取得
D列输入自己想要的文件
如:
按【重命名】按键就可以啦
【代码】
'获取文件按钮,先取得文件的路径与文件名存入字典,再输入到工作表中
Sub 多选文件得路径存入字典()
Dim i As Integer, Fso As Object, ff As Object, mydic As Object
Dim strfiel
Set Fso = CreateObject("Scripting.FileSystemObject")
Set mydic = CreateObject("Scripting.Dictionary")
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.InitialFileName = ThisWorkbook.Path
If .Show = -1 Then
For i = 1 To .SelectedItems.Count
Set ff = Fso.GetFile(.SelectedItems(i))
mydic(mydic.Count) = Array(i, ff.ParentFolder & "\", ff.Name)
Next i
Else
MsgBox "你取消了": Exit Sub
End If
End With
With Worksheets("重命名")
.Range("A3:E" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
For j = 0 To UBound(mydic.keys)
in_row = j + 3
.Range("a" & in_row).Resize(1, 3) = mydic(j)
Next j
End With
End Sub
'重命名按钮
Sub 批量重命名()
t = Timer
With Worksheets("重命名")
On Error Resume Next
hh = .Range("A65536").End(xlUp).Row
For i = 3 To hh
y_name = .Cells(i, 2) + .Cells(i, 3).Value
x_name = .Cells(i, 2) + .Cells(i, 4).Value
Name y_name As x_name
Next
End With
MsgBox "完成,用时:" & Timer - t
On Error GoTo 0
End Sub
【说明】
用到字典的items存入数组,再取出一个一个的key对应的item,存入工作表的一行一行。
关键的代码是:
mydic(mydic.Count) = Array(i, ff.ParentFolder & "\", ff.Name)
.Range("a" & in_row).Resize(1, 3) = mydic(j)
Name y_name As x_name