VBA系列-023.批量给工作簿重命名

023.批量给工作簿重命名

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