VBA – 解决问题Excel的保存临时文件的解决办法

保存特定的工作簿时，Excel创build临时文件而不是保存数据（不显示错误或警告消息）。 症状大致是相同的，在这篇文章中描述： 微软的Excel的返回错误的文件不保存后生成一个2GB的临时文件我尝试了几个解决scheme，但决定实施一项工作“另存为”工作正常。

下面的代码根据文件名以值结尾（例如myFile V1.xlsm）执行“另存为”，每次保存工作簿时macros将添加一个增量字符（a到z）。 （例如myFile V1a.xlsm）。

macros在标准模块中工作正常，但是当移动到“thisWorkbook”时，会导致Excel“停止响应”。 我通过将其保存在标准模块中，并将键组合“control-s”分配给macros来解决这个问题。 仍然有兴趣知道是否可以在“ThisWorkbook”工作。

此变通办法的缺点是每个增量保存会阻塞“最近的文件”列表。 从最近的文件历史logging中删除以前的文件名是很好的，但是这似乎不可能通过VBA来完成。 （ VBA – 如何从Excel 2007中最近的文档列表中删除文件？ ）。 有什么build议么？

Windows 10，Excel 2016（版本16.0.6868.2060）

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim newFilename As String Dim oldFilename As String oldFilename = ActiveWorkbook.Name newFilename = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) If IsNumeric(Right(newFilename, 1)) = True Then ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path + "\" + newFilename & "a.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False Else If Right(newFilename, 1) = "z" Then MsgBox "'z' reached, please save as new version" Exit Sub End If newFilename = Left(newFilename, Len(newFilename) - 1) & Chr(Asc(Right(newFilename, 1)) + 1) ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path + "\" + newFilename & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False End If 'potential code to remove oldFilename from 'Recent File' list End Sub 

Answer 1

我在Excel 2010中testing了这个Sub，它适用于我。 我删除文件后，立即打破循环，因为我认为索引可能不符合循环。 更精确的变体可能循环遍历最近的文件列表并创build要删除的索引集合，然后遍历该集合，并依次删除每个条目。

 Public Sub RemoveRecentFile(strFileName As String) Dim collRecentFiles As Excel.RecentFiles Dim objRecentFile As Excel.RecentFile Dim intRecentFileCount As Integer Dim intCounter As Integer Set collRecentFiles = Application.RecentFiles intRecentFileCount = collRecentFiles.Count For intCounter = 1 To intRecentFileCount Set objRecentFile = collRecentFiles(intCounter) If objRecentFile.Name = strFileName Then objRecentFile.Delete Exit For End If Next intCounter End Sub 

Answer 2

感谢罗宾的工作解决scheme如下：

更新初始代码：

  Sub incrementSaveAs() 'to avoid that other workbooks are saved (when assigned to shortkey control-S) If ActiveWorkbook.Name <> ThisWorkbook.Name Then ActiveWorkbook.Save: Exit Sub Dim newFilename As String Dim oldFilename As String oldFilename = ActiveWorkbook.Name newFilename = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) If IsNumeric(Right(newFilename, 1)) = True Then ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path + "\" + newFilename & "a.xlsm", _ FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False, AddToMru:=True 'AddToMru:=True Added to update recent files history Else If Right(newFilename, 1) = "z" Then MsgBox "'z' reached, please save as new version" Exit Sub End If newFilename = Left(newFilename, Len(newFilename) - 1) & Chr(Asc(Right(newFilename, 1)) + 1) ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path + "\" + newFilename & ".xlsm", _ FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False, AddToMru:=True End If RemoveRecentFile (ActiveWorkbook.Path & Application.PathSeparator & oldFilename) End Sub 

更新罗宾的代码：

 Public Sub RemoveRecentFile(strPathAndFileName As String) Dim collRecentFiles As Excel.RecentFiles Dim objRecentFile As Excel.RecentFile Dim intRecentFileCount As Integer Dim intCounter As Integer Set collRecentFiles = Application.RecentFiles intRecentFileCount = collRecentFiles.Count For intCounter = 1 To intRecentFileCount Set objRecentFile = collRecentFiles(intCounter) If objRecentFile.Path = strPathAndFileName Then objRecentFile.Delete Exit For End If Next intCounter End Sub