Sub ReName() Dim Mypath As String Dim Myfile As String Dim WBName As String Dim WS As Worksheet Application.DisplayAlerts = False With Application.FileDialog(msoFileDialogFolderPicker) .Show If .SelectedItems.Count = 0 Then Exit Sub Mypath = .SelectedItems(1) End With Myfile = Dir(Mypath & "\*.xls*") Do Until Myfile = "" With Workbooks.Open(Mypath & "\" & Myfile) WBName = Left(.Name, Len(.Name) - 4) For Each WS In .Sheets WS.Name = WBName & WS.Name Next .Close Savechanges:=True End With Myfile = Dir Loop Application.DisplayAlerts = True MsgBox "OK" End Sub |
