Sub 批量獲取文件名()
Cells = "" '清空工作表內(nèi)容
Dim sfso
Dim myPath As String
Dim Sh As Object
Dim Folder As Object
Application.ScreenUpdating = False
On Error Resume Next
Set sfso = CreateObject("Scripting.FileSystemObject")
Set Sh = CreateObject("shell.application")
Set Folder = Sh.BrowseForFolder(0, "", 0, "")
If Not Folder Is Nothing Then
  myPath = Folder.Items.Item.Path
End If
Application.ScreenUpdating = True
Cells(1, 1) = "舊版名稱(chēng)"
Cells(1, 2) = "文件類(lèi)型"
Cells(1, 3) = "所在位置"
Cells(1, 4) = "新版名稱(chēng)"
Call 直接提取文件名(myPath & "\")
End Sub
Sub 直接提取文件名(myPath As String)
    Dim i As Long
    Dim myTxt As String
    i = Range("A1048576").End(xlUp).Row
    '這里的31,是把0、1、2、4、8、16    '加起來(lái)得到的,表示這些類(lèi)型的文件都讀取    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 '加'轉(zhuǎn)成文本                        '形成超鏈接 可以打開(kāi)文件            Cells(i, 1).Hyperlinks.Add Anchor:=Cells(i, 1), Address:=myPath & 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)            Cells(i, 3).Hyperlinks.Add Anchor:=Cells(i, 3), Address:=Left(myPath, Len(myPath) - 1)        End If
        myTxt = Dir
    Loop
End Sub
Sub 批量重命名()
Dim y_name As String
Dim x_name As String
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       If Cells(i, 4) <> "" Then Name y_name As x_name 'Y名字被改成X名字
Next
MsgBox "重命名完成"
End Sub