'v2
Dim fso As Object
 
Private Sub Workbook_Open()
    RenameInCurrentFolder
    Application.Quit
End Sub
 
Sub RenameInCurrentFolder()
    Set fso = CreateObject("Scripting.FileSystemObject")
    FolderJob ThisWorkbook.Path
End Sub
 
Private Sub FolderJob(sFolder As String)
    Dim oFolder As Object
    On Error Resume Next
    Set oFolder = fso.GetFolder(sFolder)
    On Error GoTo 0
    If Not oFolder Is Nothing Then
        Dim oFile As Object
        For Each oFile In oFolder.Files
            FileJob CStr(oFile)
        Next
         
        Dim oSubFolder As Object
        For Each oSubFolder In oFolder.SubFolders
            FolderJob oSubFolder.Path
        Next
    End If
End Sub
 
Private Sub FileJob(sFile As String)
    Dim newFull As String
    Dim sName As String
    sName = fso.GetFileName(sFile)
    If Left(sName, 2) = "~$" Then Exit Sub
     
    If sName Like "*##.####*" Then
        Dim ii As Long
        Dim ss As String
        Do
            ii = InStr(ii + 1, sName, ".")
            If ii = 0 Then Exit Do
            If ii > 2 Then
                If Mid(sName, ii - 2, 7) Like "##.####" Then
                    If Right(Mid(sName, 1, ii - 3), 1) = " " And Left(Mid(sName, ii + 5), 1) = " " Then
                        ss = Mid(sName, 1, ii - 3) & Mid(sName, ii + 6)
                    Else
                        ss = Mid(sName, 1, ii - 3) & Mid(sName, ii + 5)
                    End If
                    newFull = fso.GetParentFolderName(sFile) & Application.PathSeparator & ss
                    On Error Resume Next
                    Kill newFull
                    Name sFile As newFull
                    If fso.FileExists(newFull) Then Kill sFile
                    On Error GoTo 0
                End If
            End If
        Loop
    End If
End Sub