VBA批量给工作簿重命名

Sub GetFiles()

    Dim strPath As String, strFileName As String, k As Long

    With Application.FileDialog(msoFileDialogFolderPicker)

        If .Show Then strPath = .SelectedItems(1) Else: Exit Sub

        '获取用户选择的文件夹的路径，如果未选取，则退出程序

    End With

    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

    Application.ScreenUpdating = False

    Range("a:b").Clear: k = 1

    '清除A:B列的所有

    Cells(1, 1) = "旧文件名": Cells(1, 2) = "新文件名"

    strFileName = Dir(strPath & "*.xls*")

    Do While strFileName <> ""

        k = k + 1

        Cells(k, 1) = strPath & strFileName

        strFileName = Dir

    Loop

    Application.DisplayAlerts = True

End Sub

Sub ChangeFileName()

    Dim r, i As Long

    r = Range("a1").CurrentRegion '数据装入数组

    For i = 2 To UBound(r)

    '标题行不要，从数组第二行开始遍历

        Name r(i, 1) As r(i, 2) 'Name语句重命名

    Next

    MsgBox "更名完成。"

End Sub