[已解决]除了menu页，其他页子另存为一个总的工作薄怎么操作！！！

zte10157616

数据核查完之后，我要指定在D盘根目录生成一个格式总表（截图中不包含Menu页）的新工作薄，请问如何操作；

新工作薄不包括宏等杂物，谢谢。



而且运行完毕，程序工作薄界面仍然是截图所示的激活状态。

最佳答案

月排行榜 / 总排行榜

dsmch

2014-3-30 14:23

Sub Macro1()
On Error Resume Next
Dim i&, zf$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
For i = 1 To Sheets.Count
    If Sheets(i).Name <> "Menu" Then
        zf = Sheets(i).Name & ".xls" '文件名
        With Workbooks.Add
            For j = 2 To ThisWorkbook.Sheets.Count
                ThisWorkbook.Sheets(j).Copy after:=.Sheets(.Sheets.Count)
            Next
            .Sheets(1).Delete
            .SaveAs Filename:=ThisWorkbook.Path & "\" & zf '路径+文件名
        End With
        Workbooks(zf).Close 1
    End If
Next
Application.SheetsInNewWorkbook = 3
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

跳转到最佳答案楼层

zte10157616

求指导

zte10157616

？？？？

zte10157616

求大侠知道啊……摸索的代码一直效果不如意！

dsmch

用附件说明问题，可以做到的

zte10157616

dsmch 发表于 2014-3-30 08:08
用附件说明问题，可以做到的

附件较大上传不了！！！

zte10157616

dsmch 发表于 2014-3-30 08:08
用附件说明问题，可以做到的

中兴TD-LTE参数核查工具_ICM_V2.2_For_China_600_beta.zip (317.94 KB, 下载次数: 12)

2014-3-30 12:27 上传

点击文件名下载附件

附件如下，如何写一个代码将程序另存为除Menu外其他sheet组成的新工作薄，然后新工作薄另存位置在D盘根目录，命名格式某某某_时间的，XLSX文件；

我试过经过几步周转来实现，效果不如意，请大侠帮忙看看如何写一个另存代码！！！多谢

dsmch

zte10157616 发表于 2014-3-30 12:29
附件如下，如何写一个代码将程序另存为除Menu外其他sheet组成的新工作薄，然后新工作薄另存位置在D盘 ...

vbe密码

zte10157616

dsmch 发表于 2014-3-30 12:43
vbe密码

更新！！！

dsmch

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim i&, zf$
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. Application.SheetsInNewWorkbook = 1
   
7. For i = 1 To Sheets.Count
   
8.     If Sheets(i).Name <> "Menu" Then
   
9.         zf = Sheets(i).Name & ".xls" '文件名
   
10.         With Workbooks.Add
    
11.             ThisWorkbook.Sheets(i).Copy after:=.Sheets(.Sheets.Count)
    
12.             .Sheets(1).Delete
    
13.             .SaveAs Filename:=ThisWorkbook.Path & "" & zf '路径+文件名
    
14.         End With
    
15.         Workbooks(zf).Close 1
    
16.     End If
    
17. Next
    
18. Application.SheetsInNewWorkbook = 3
    
19. Application.DisplayAlerts = True
    
20. Application.ScreenUpdating = True
    
21. End Sub
    

复制代码