在EXCEL中如何用VBA另保存特定的工作表,比如有A1,A2,A3,A4,A5,A6,而我只想另存A3,A4,A5,A6到一个新的EXCEL,文件名用A1表中的A1单元格的值.
说清楚点,最好有代码例子
代码如下：<br>sub 分开存为工作薄()<br><br>dim sh as worksheet<br>dim wk1 as workbook<br>dim wk2 as workbook<br>dim ipath as string<br><br>application.screenupdating = false ‘将屏幕更新关闭<br>application.displayalerts = false<br><br>ipath = thisworkbook.path & "\" '保存路径为当前工作簿所在路径<br>set wk1 = workbooks.add<br>set wk2 = workbooks.add<br>wk1.saveas ipath & "部门" & ".xls"<br>wk2.saveas ipath & "基层" & ".xls"<br>'将工作表分别复制到部门或基层工作薄中<br>for each sh in thisworkbook.worksheets<br> with sh<br> if .name like "*部门*" then<br> .copy before:=workbooks("部门").worksheets("sheet1")<br> elseif .name like "*基层*" then<br> .copy before:=workbooks("基层").worksheets("sheet1")<br> else<br> msgbox "工作表" & .name & "不含有部门或基层"<br> end if<br> end with<br>next<br> '删除新建工作薄时默认新建的工作表<br>for each sh in wk1.worksheets<br> with sh<br> if .name like "*sheet*" then<br> .delete<br> end if<br> end with<br>next<br>for each sh in wk2.worksheets<br> with sh<br> if .name like "*sheet*" then<br> .delete<br> end if<br> end with<br>next<br>'保存部门和基层工作薄<br>wk1.save<br>wk2.save<br>wk1.close<br>wk2.close<br>set wk1 = nothing<br>set wk2 = nothing<br>application.displayalerts = true<br>application.screenupdating = true<br>end sub<br>其中application.displayalerts、 application.screenupdating 语句把过程中的无必要的警告都删除了，像在删除多余的工作表时会提示“数据可能在你要删除的工作表中，请问是否要删除”等等的警告，在写程序的过程中可以写不加人，有利于了解工程是怎么运作的，但是最后还是加上这两句比较好，否则用户使用时太多的警告信息感觉不是很好。<br>.copy before:=workbooks("基层").worksheets("sheet1")<br>此句是拷贝sheet到新的xls里，由于使用了with语句，前面的workbook的信息省略了，但是有copy before与copy after注意选择，具体区别自己也不是很清楚。workbooks("基层").worksheets("sheet1")拷贝到基层.xls的sheet1里，但是看到下面删除sheet时并没有把此表分别开，会不会出错？<br>以下是我自己的程序：<br>set sht = newbk.worksheets(1) '删除新建的newbk里的两个sheet，必须留一个，否则会出错<br>sht.delete<br>set sht = newbk.worksheets(1)<br>sht.delete<br>oldbk.worksheets(ssheetname).copy after:=newbk.worksheets(1) '拷贝<br>set sht = newbk.worksheets(1) ’删除一个工作表，会删错么？<br>sht.delete<br>newbk.worksheets(1).name = ssheetname<br>newbk.save<br>拷贝处选用的是worksheets(1)，本想用worksheets(ssheetname)，但是系统出错，应该是新xls中没有此sheet，只有默认的1、2、3，所以出错。<br>对删除工作表的操作表示疑问，因为怕删错，worksheets(1）是选择当前最前端的窗口，此程序测试正确，那么应该是新生成的没有作为active？<br>===============================================<br>所以拷贝时有3个问题：<br>1、copy before 与copy after的区别？<br>2、copy后新的名称是什么？<br>3、copy后的表是不是最前端的？<br><br>从网上看到的，可以对第一个问题很好的解释：<br>sheets("mainreport").copy before:=sheets(4)<br>after：是将表mainreport创建拷贝到‘4’表的后面<br>before：是将表mainreport创建拷贝到‘4’表的前面<br>是一个位置的问题
温馨提示：答案为网友推荐，仅供参考
第1个回答 2019-01-17
代码如下：<br>sub 分开存为工作薄()<br><br>dim sh as worksheet<br>dim wk1 as workbook<br>dim wk2 as workbook<br>dim ipath as string<br><br>application.screenupdating = false ‘将屏幕更新关闭<br>application.displayalerts = false<br><br>ipath = thisworkbook.path & "\" '保存路径为当前工作簿所在路径<br>set wk1 = workbooks.add<br>set wk2 = workbooks.add<br>wk1.saveas ipath & "部门" & ".xls"<br>wk2.saveas ipath & "基层" & ".xls"<br>'将工作表分别复制到部门或基层工作薄中<br>for each sh in thisworkbook.worksheets<br> with sh<br> if .name like "*部门*" then<br> .copy before:=workbooks("部门").worksheets("sheet1")<br> elseif .name like "*基层*" then<br> .copy before:=workbooks("基层").worksheets("sheet1")<br> else<br> msgbox "工作表" & .name & "不含有部门或基层"<br> end if<br> end with<br>next<br> '删除新建工作薄时默认新建的工作表<br>for each sh in wk1.worksheets<br> with sh<br> if .name like "*sheet*" then<br> .delete<br> end if<br> end with<br>next<br>for each sh in wk2.worksheets<br> with sh<br> if .name like "*sheet*" then<br> .delete<br> end if<br> end with<br>next<br>'保存部门和基层工作薄<br>wk1.save<br>wk2.save<br>wk1.close<br>wk2.close<br>set wk1 = nothing<br>set wk2 = nothing<br>application.displayalerts = true<br>application.screenupdating = true<br>end sub<br>其中application.displayalerts、 application.screenupdating 语句把过程中的无必要的警告都删除了，像在删除多余的工作表时会提示“数据可能在你要删除的工作表中，请问是否要删除”等等的警告，在写程序的过程中可以写不加人，有利于了解工程是怎么运作的，但是最后还是加上这两句比较好，否则用户使用时太多的警告信息感觉不是很好。<br>.copy before:=workbooks("基层").worksheets("sheet1")<br>此句是拷贝sheet到新的xls里，由于使用了with语句，前面的workbook的信息省略了，但是有copy before与copy after注意选择，具体区别自己也不是很清楚。workbooks("基层").worksheets("sheet1")拷贝到基层.xls的sheet1里，但是看到下面删除sheet时并没有把此表分别开，会不会出错？<br>以下是我自己的程序：<br>set sht = newbk.worksheets(1) '删除新建的newbk里的两个sheet，必须留一个，否则会出错<br>sht.delete<br>set sht = newbk.worksheets(1)<br>sht.delete<br>oldbk.worksheets(ssheetname).copy after:=newbk.worksheets(1) '拷贝<br>set sht = newbk.worksheets(1) ’删除一个工作表，会删错么？<br>sht.delete<br>newbk.worksheets(1).name = ssheetname<br>newbk.save<br>拷贝处选用的是worksheets(1)，本想用worksheets(ssheetname)，但是系统出错，应该是新xls中没有此sheet，只有默认的1、2、3，所以出错。<br>对删除工作表的操作表示疑问，因为怕删错，worksheets(1）是选择当前最前端的窗口，此程序测试正确，那么应该是新生成的没有作为active？<br>===============================================<br>所以拷贝时有3个问题：<br>1、copy before 与copy after的区别？<br>2、copy后新的名称是什么？<br>3、copy后的表是不是最前端的？<br><br>从网上看到的，可以对第一个问题很好的解释：<br>sheets("mainreport").copy before:=sheets(4)<br>after：是将表mainreport创建拷贝到‘4’表的后面<br>before：是将表mainreport创建拷贝到‘4’表的前面<br>是一个位置的问题
第2个回答 推荐于2018-04-29
Sub CopySelectedSheets()
'定义新工作簿名称为NewBookName
Dim NewBookName As String
'获取原工作簿(这里的名字是text.xls)第一张表格里的A1单元格内的值作为NewBookName的值
NewBookName = Workbooks("text.xls").Worksheets(1).Range("a1").Text
'复制原工作簿中第1,3,4张工作表至新的空白工作簿中
Workbooks("text.xls").Worksheets(Array(1, 3, 4)).Copy
'将新工作簿重命名为NewBookName的值
ActiveWorkbook.SaveAs NewBookName
End Sub本回答被提问者和网友采纳
'定义新工作簿名称为NewBookName
Dim NewBookName As String
'获取原工作簿(这里的名字是text.xls)第一张表格里的A1单元格内的值作为NewBookName的值
NewBookName = Workbooks("text.xls").Worksheets(1).Range("a1").Text
'复制原工作簿中第1,3,4张工作表至新的空白工作簿中
Workbooks("text.xls").Worksheets(Array(1, 3, 4)).Copy
'将新工作簿重命名为NewBookName的值
ActiveWorkbook.SaveAs NewBookName
End Sub本回答被提问者和网友采纳
第3个回答 2008-10-18
只能保存整个工作簿
Sub mm()
ActiveWorkbook.SaveAs Filename:=[a1], FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
End Sub
Sub mm()
ActiveWorkbook.SaveAs Filename:=[a1], FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
End Sub
第4个回答 2008-10-19
另存到新的表格中
Sub test()
Dim SheetName1 As String
Dim SheetName2 As String
SheetName1 = ActiveSheet.Name
SheetName2 = ActiveSheet.Range("a1")
Worksheets.Add
ActiveSheet.Name = SheetName2
Worksheets(SheetName1).Range("a3:a6").Copy Worksheets(SheetName2).Range("a1")
End Sub
Sub test()
Dim SheetName1 As String
Dim SheetName2 As String
SheetName1 = ActiveSheet.Name
SheetName2 = ActiveSheet.Range("a1")
Worksheets.Add
ActiveSheet.Name = SheetName2
Worksheets(SheetName1).Range("a3:a6").Copy Worksheets(SheetName2).Range("a1")
End Sub
