1、工作铺中有10个工作表。2、工作表名都为汉字,9个工作表引用第一个工作表内容。3、需要将其中一个工作表如[销售表清单]另存在另一盘中,以其中D16单元格内容为文件名,谢谢,请懂的指教,最好写出代码及详解!!
Sub save_data()
Dim new_Book As Workbook
Set new_Book = Workbooks.Add ' 新建一个EXCEL文件
ThisWorkbook.Sheets("指定工作表").Copy before:=new_Book.Sheets(1) ' 将“指定工作表”复制到新文件中
new_Book.Activate ' 切换到新文件
Cells.Select ' 全选单元格
Selection.Copy ' 复制并选择性粘贴为数值,去除公式
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
new_Book.SaveAs "D:\" & Range("D16") & ".xls" ' 以D16中的内容为文件名,保存至D盘根目录下
End Sub
Dim new_Book As Workbook
Set new_Book = Workbooks.Add ' 新建一个EXCEL文件
ThisWorkbook.Sheets("指定工作表").Copy before:=new_Book.Sheets(1) ' 将“指定工作表”复制到新文件中
new_Book.Activate ' 切换到新文件
Cells.Select ' 全选单元格
Selection.Copy ' 复制并选择性粘贴为数值,去除公式
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
new_Book.SaveAs "D:\" & Range("D16") & ".xls" ' 以D16中的内容为文件名,保存至D盘根目录下
End Sub
温馨提示:答案为网友推荐,仅供参考
第1个回答 2013-03-21
Sub 另存()
Application.ScreenUpdating = False '关闭屏幕更新
Worksheets("销售表清单").Copy '复制需要的表
ActiveSheet.UsedRange.Copy '将复制出来的表已用区域复制
ActiveSheet.UsedRange.PasteSpecial xlPasteValues '选择性粘贴
ActiveWorkbook.SaveAs "D:\" & ActiveSheet.Range("D16").Value & ".XLS" '已D16为文件名保存到指定目录
ActiveWorkbook.Close True '保存并关闭
Application.ScreenUpdating = True
End Sub
Application.ScreenUpdating = False '关闭屏幕更新
Worksheets("销售表清单").Copy '复制需要的表
ActiveSheet.UsedRange.Copy '将复制出来的表已用区域复制
ActiveSheet.UsedRange.PasteSpecial xlPasteValues '选择性粘贴
ActiveWorkbook.SaveAs "D:\" & ActiveSheet.Range("D16").Value & ".XLS" '已D16为文件名保存到指定目录
ActiveWorkbook.Close True '保存并关闭
Application.ScreenUpdating = True
End Sub
第2个回答 2013-03-21
参考这个。。别人的回答,顺便学习一下
saveas 的文件名应该是可以带路径的
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
saveas 的文件名应该是可以带路径的
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