Sub Пример()
    Dim wb As Workbook, sFilePath As String, sFileName As String, sDeleteFile As String
    
    For Each wb In Workbooks
        If wb.Name <> ThisWorkbook.Name Then wb.Close False' True если надо сохранить
    Next wb
    
    sFilePath = ThisWorkbook.Path & Application.PathSeparator
    sFileName = Dir(sFilePath & "\*", vbHidden + vbDirectory)
    
    Do While sFileName <> ""
        If sFileName <> "." And sFileName <> ".." And InStr(1, sFileName, "~") = 0 Then
            sDeleteFile = sFilePath & sFileName
            ' снятие аттрибутов "Скрытый", "Системный" и "Только для чтения"
            VBA.SetAttr sDeleteFile, (VBA.GetAttr(sDeleteFile) And vbArchive)
            If sDeleteFile <> ThisWorkbook.FullName Then Kill (sDeleteFile)
        End If
        sFileName = Dir
    Loop
End Sub

Sub ThisWorkbookKill()
  Dim sPathForSave$, WB As Workbook
  Set WB = ThisWorkbook
  sPathForSave = WB.Path & "\SaveFolder\" ' папка должна существовать
'  или тогда
  VBA.MkDir (sPathForSave)  ' создает папку
  WB.SaveCopyAs sPathForSave & WB.Name
  WB.ChangeFileAccess xlReadOnly
  VBA.Kill (WB.FullName)
  WB.Close False
End Sub