【求助】如何通过VBA实现将一个工作簿中多个指定工作表另存为一个无公式的新工作簿

yifei1357

我想将除首页外的其他四个工作表另存为一个新工作簿，并且让新工作簿中的单元格不包含公式而源文件公式不变！求助各位大侠，谢谢！

zhaogang1960

1. Sub Macro1()
   
2.     Dim sh As Worksheet, p$
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     p = ThisWorkbook.Path & ""
   
6.     For Each sh In Worksheets
   
7.         If sh.Visible = xlSheetVisible And sh.Name <> "首页" Then
   
8.             sh.Copy
   
9.             ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
   
10.                 , AllowFiltering:=True, AllowUsingPivotTables:=True
    
11.             ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
    
12.                 False, AllowFiltering:=True, AllowUsingPivotTables:=True
    
13.             ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:= _
    
14.                 False, AllowFiltering:=True, AllowUsingPivotTables:=True
    
15.             ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
    
16.                 True, AllowFiltering:=True, AllowUsingPivotTables:=True
    
17.             ActiveSheet.Unprotect
    
18.             With ActiveSheet.UsedRange
    
19.                 .Value = .Value
    
20.             End With
    
21.             For Each shp In ActiveSheet.Shapes
    
22.                 shp.Delete
    
23.             Next
    
24.             ActiveWorkbook.Close True, p & sh.Name & ".xls"
    
25.         End If
    
26.     Next
    
27.     Application.ScreenUpdating = True
    
28.     MsgBox "保存完毕"
    
29. End Sub
    

复制代码

zhaogang1960

由于你的工作表保护，才加了9——17行多余的破解密码代码，如果你撤销工作表保护，可以删除它们
请看附件
111.rar (448.46 KB, 下载次数: 279)

2014-2-7 18:10 上传

点击文件名下载附件

yifei1357

zhaogang1960 发表于 2014-2-7 18:11
由于你的工作表保护，才加了9——17行多余的破解密码代码，如果你撤销工作表保护，可以删除它们
请看附件
...

谢谢，我试了下，结果是每个工作表另存，我想把那几个工作表放在同一个工作簿中，请大师再看看，多谢！另为什么用wps会提示错误呢？

zhaogang1960

yifei1357 发表于 2014-2-7 18:28
谢谢，我试了下，结果是每个工作表另存，我想把那几个工作表放在同一个工作簿中，请大师再看看，多谢！另 ...

1. Sub Macro1()
   
2.     Dim sh As Worksheet, p$
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     p = ThisWorkbook.Path & ""
   
6.     For Each sh In Worksheets
   
7.         If sh.Visible = xlSheetVisible And sh.Name <> "首页" Then
   
8.             sh.Copy
   
9.             ActiveSheet.Unprotect ("000000")
   
10.             With ActiveSheet.UsedRange
    
11.                 .Value = .Value
    
12.             End With
    
13.             For Each shp In ActiveSheet.Shapes
    
14.                 shp.Delete
    
15.             Next
    
16.             ActiveSheet.Protect ("000000")
    
17.             ActiveWorkbook.Close True, p & sh.Name & ".xls"
    
18.         End If
    
19.     Next
    
20.     Application.ScreenUpdating = True
    
21.     MsgBox "保存完毕"
    
22. End Sub

复制代码

zhaogang1960

请看附件
111.rar (448.06 KB, 下载次数: 212)

2014-2-7 18:48 上传

点击文件名下载附件

yifei1357

zhaogang1960 发表于 2014-2-7 18:47

多谢，可能我没说清楚，我只想生成一个工作簿包含要另存的几个工作表，麻烦了！

zhaogang1960

yifei1357 发表于 2014-2-7 19:00
多谢，可能我没说清楚，我只想生成一个工作簿包含要另存的几个工作表，麻烦了！

1. Sub Macro1()
   
2.     Dim sh As Worksheet, m&
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     For Each sh In Worksheets
   
6.         If sh.Visible = xlSheetVisible And sh.Name <> "首页" Then
   
7.             m = m + 1
   
8.             If m = 1 Then sh.Select Else sh.Select False
   
9.         End If
   
10.     Next
    
11.     ActiveWindow.SelectedSheets.Copy
    
12.     For Each sh In Worksheets
    
13.         sh.Unprotect ("000000")
    
14.         With sh.UsedRange
    
15.             .Value = .Value
    
16.         End With
    
17.         For Each shp In sh.Shapes
    
18.             shp.Delete
    
19.         Next
    
20.         sh.Protect ("000000")
    
21.     Next
    
22.     ActiveWorkbook.Close True, ThisWorkbook.Path & "\备份.xls"
    
23.     Sheets("首页").Select
    
24.     Application.ScreenUpdating = True
    
25.     MsgBox "保存完毕"
    
26. End Sub
    

复制代码

zhaogang1960

请测试附件
111.rar (448.91 KB, 下载次数: 426)

2014-2-7 19:27 上传

点击文件名下载附件

yifei1357

zhaogang1960 发表于 2014-2-7 19:26

还得麻烦一下，可否保留工作表表头的图片，打印要用到。