批量修改文件名（转载）

批量修改文件名

 

' 程序用法

' 0、添加要命名的文件夹的路径第一个sub的第二行，指定myPath的名称
' 1、运行 Sub 批量获取文件名()

' 2、在D列添加新的文件名称，

'模板是为了批量增加年份的前缀，所以里面有公式。 但是sheet中的内容可以删除。 年份的公司在sheet2中有备份。

' 3、Sub 批量重命名()
' 4、删除A到内容()

' 把光标放到下面对应的sub中，点F5就可以运行了。




Sub 批量获取文件名()

Dim myPath$

  myPath = "E:\2_工程软件\FEMFAT Lab\1_VI演讲PPT"   '这个地方要修改

Cells(1, 1) = "旧版名称": Cells(1, 2) = "文件类型": Cells(1, 3) = "所在位置": Cells(1, 4) = "新版名称"

Call 直接提取文件名(myPath & "\")


End Sub


Sub 批量重命名()

Dim y_name$, x_name$

For i = 2 To Range("A1048576").End(xlUp).Row

   y_name = Cells(i, 3) & "\" & Cells(i, 1)
   x_name = Cells(i, 3) & "\" & Cells(i, 4)

   On Error Resume Next

   Name y_name As x_name

Next

End Sub


Sub 删除A到C的内容()

Range("A:A") = "": Range("B:B") = "": Range("C:C") = "":



End Sub


Sub 直接提取文件名(myPath As String)

    Dim i As Long

    Dim myTxt As String

    i = Range("A1048576").End(xlUp).Row

    myTxt = Dir(myPath, 31)

    Do While myTxt <> ""

    On Error Resume Next

        If myTxt <> ThisWorkbook.Name And myTxt <> "." And myTxt <> ".." And myTxt <> "081226" Then

            i = i + 1

            Cells(i, 1) = "'" & myTxt

            If (GetAttr(myPath & myTxt) And vbDirectory) = vbDirectory Then

                Cells(i, 2) = "文件夹"

            Else

                Cells(i, 2) = "文件"

 End If

            Cells(i, 3) = Left(myPath, Len(myPath) - 1)

        End If

        myTxt = Dir

    Loop

End Sub