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
