如何批量删除所有打开的excel文件中的公式，保留公式结果？

focuson1

    工作中的很多工作簿中使用了很多函数公式，导致运行时速度变慢，有些这样的文件要建档保存最后一次运行结果，公式就不必要存在了。如果按照常规操作方法，使用选择性粘贴可以删除公式保留结果，但是这样工作效率不高。

使用VBA可以批量定位所有打开的工作簿中含有公式的单元格，并删除公式保留最后一次运行所得的结果吗？这个如何实现？

我尝试了如下代码，

1. Private Sub workbook_open()
   
2.     If Now() >= #10/9/2016# Then
   
3.     Dim wkb As Workbook
   
4.     For Each wkb In Workbooks
   
5.     If wkb.Name <> ThisWorkbook.Name Then
   
6.    
   
7.     wkb.UsedRange.value = wkb.UsedRange.Value
   
8. wkb.close savechanges:=true
   
9.     End If
   
10.    
    
11.     Next wkb
    
12.     End If
    
13.    
    
14. End Sub
    

复制代码

提示：


如何改写代码呢？谢谢！

focuson1

朱荣兴 发表于 2016-10-10 11:06
你现在的代码根本没有打开工作簿，所以有错，必须建立一个目录，依次打开再把公式转换为数值

谢谢您的指点，请问侠圣，所有要删除公式保留结果的文件簿都在桌面一个名为1的文件夹中，如何用vba代码删除公式保留结果呢？谢谢！

focuson1

朱荣兴 发表于 2016-10-10 11:12
没有附件，只能给你一个思路：新建一个工作簿，把这个工作簿把存到其它工作簿的同一个位置，然后在新建工作 ...

1.rar (28.9 KB, 下载次数: 34)

2016-10-10 11:20 上传

点击文件名下载附件

已上传附件：

要求删除1这个文件夹中所有工作簿中所有工作表中的公式保留结果。

focuson1

朱荣兴 发表于 2016-10-10 11:12
没有附件，只能给你一个思路：新建一个工作簿，把这个工作簿把存到其它工作簿的同一个位置，然后在新建工作 ...


运行下面代码为什么提示这样的错误？

1. Sub 批量转换()
   
2. Application.ScreenUpdating = False
   
3. Dim wb As Excel.Workbook
   
4. f = Dir(ThisWorkbook.Path & "C:\Users\Abc\Desktop\1\*.xls*") '生成查找EXCEL的目录,可以适应不同版本
   
5. Do While f <> "" '在目录中循环
   
6. If f <> ThisWorkbook.Name Then  '如果不是打开的工作簿
   
7. Set wb = Workbooks.Open(ThisWorkbook.Path & "C:\Users\Abc\Desktop\1" & f) '依次打开目录工作薄
   
8. wb.Worksheets(1).UsedRange.Value = wb.Worksheets(1).UsedRange.Value '假定你需要转换的是第一张工作表
   
9.     wb.Close True '关闭并保存打开的工作薄
   
10.     End If
    
11.     f = Dir
    
12.     Loop '结束循环
    
13.     Application.ScreenUpdating = True
    
14. End Sub

复制代码

focuson1

请问老师：

1. f = Dir(ThisWorkbook.Path & "C:\Users\Abc\Desktop\1\*.xls*")
   
2. 
   
3. Set wb = Workbooks.Open(ThisWorkbook.Path & "C:\Users\Abc\Desktop\1" & f)

复制代码

代码中的路径是这么写的，有错误吗？

focuson1

1. Sub 批量转换()
   
2. Application.ScreenUpdating = False
   
3. Dim wb As Excel.Workbook
   
4. f = Dir(ThisWorkbook.Path & "C:\Users\Abc\Desktop\1\*.xls*") '生成查找EXCEL的目录,可以适应不同版本
   
5. Do While f <> "" '在目录中循环
   
6. If f <> ThisWorkbook.Name Then  '如果不是打开的工作簿
   
7. Set wb = Workbooks.Open(ThisWorkbook.Path & "C:\Users\Abc\Desktop\1" & f) '依次打开目录工作薄
   
8.     For Each sht In wb.Sheets
   
9.     sht.UsedRange.Value = sht.UsedRange.Value
   
10.     Next sht
    
11.     wb.Close True '关闭并保存打开的工作薄
    
12.     End If
    
13.     f = Dir
    
14.     Loop '结束循环
    
15.     Application.ScreenUpdating = True
    
16. End Sub
    

复制代码

focuson1

1. Sub 批量转换()
   
2. Application.ScreenUpdating = False
   
3. Dim wb As Excel.Workbook
   
4. f = Dir(ThisWorkbook.Path & "\*.xls*") '生成查找EXCEL的目录,可以适应不同版本
   
5. Do While f <> "" '在目录中循环
   
6. If f <> ThisWorkbook.Name Then  '如果不是打开的工作簿
   
7. Set wb = Workbooks.Open(ThisWorkbook.Path & "" & f) '依次打开目录工作薄
   
8.     For Each sht In wb.Sheets
   
9.     sht.UsedRange.Value = sht.UsedRange.Value
   
10.     Next sht
    
11.     wb.Close True '关闭并保存打开的工作薄
    
12.     End If
    
13.     f = Dir
    
14.     Loop '结束循环
    
15.     Application.ScreenUpdating = True
    
16. End Sub
    

复制代码

谢谢！