批量重命名vba

Public Sub PickFolder()

'** 使用FileDialog对象来选择文件夹

        Dim fd As FileDialog

        Dim strPath As String

        Set fd = Application.FileDialog(msoFileDialogFolderPicker)

        '** 显示选择文件夹对话框

        If fd.Show = -1 Then        '** 用户选择了文件夹

            strPath = fd.SelectedItems(1)

        Else

            strPath = ""

        End If

        [B1] = strPath

        Set fd = Nothing

End Sub

Sub ReName()

    Dim arr, e

    On Error Resume Next

    For i = 4 To [A65536].End(xlUp).Row

        If Cells(i, 3) <> "" Then

            Name [B1] & "\" & Cells(i, 1) & Cells(i, 2) As [B1] & "\" & Cells(i, 3) & Cells(i, 2)

        End If

    Next

    MsgBox "重命名成功!"

End Sub

 Sub 获取目录()

    Dim fs, f, f1, s, sf

    Dim r As Range

    Set fs = CreateObject("Scripting.FileSystemObject")

    Set f = fs.GetFolder([B1])

    Set sf = f.Files

    [A4:A65536] = ""

    For Each f1 In sf

        s = f1.Name

        Set r = [A65536].End(xlUp).Offset(1)

        n = InStrRev(s, ".")

        r = Left(s, n - 1) '文件名

        r.Offset(0, 1) = Mid(s, n)  '后缀

    Next

End Sub