Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 8802|回复: 8

[已解决]怎样同时把一个工作簿中两个表导出为单独的一个工作簿

[复制链接]
发表于 2011-9-14 08:22 | 显示全部楼层 |阅读模式
本帖最后由 zzk386 于 2011-9-14 09:05 编辑

怎样同时把一个工作簿中两个表导出为单独的一个工作簿
(新工作簿中同时有表1和表2两个表)
还有一些小要求,在程序文件中有多个表,只要求表1表2的表要复制,其他的表不复制,另外表一和表二复制的区域有限定,比如表一复制的区域是("A2:E"& lr),表二复制的区域是(“A2:f"& lr1),代码如何写呢?


最佳答案
2011-9-14 09:36
本帖最后由 zjdh 于 2011-9-14 09:43 编辑

注意红色语句:

'导出2个表的数据
Sub daochu2()
    Dim fso As Scripting.FileSystemObject
    Dim myFolder As String
    Application.ScreenUpdating = False
    lr = 10
    lr1 = 20
    With ThisWorkbook
        Workbooks.Add (1)
        .Sheets(1).Range("A2:E" & lr).Copy
        ActiveSheet.Paste
        ActiveWorkbook.Sheets.Add
        .Sheets(2).Range("A2:E" & lr1).Copy
        ActiveSheet.Paste
    End With
    myFolder = "d:\数据"
    Set fso = New Scripting.FileSystemObject
    If fso.FolderExists(myFolder) Then    '如果该文件夹已经存在
        Call 导出数据
    Else
        fso.CreateFolder myFolder       '如果没有指定的文件夹就创建文件夹
        Call 导出数据
    End If
    Set fso = Nothing
    Application.ScreenUpdating = True
    MsgBox "数据已被导出,保存在D:\数据\...", 48, "导出提示"
End Sub
Sub 导出数据()
    Application.DisplayAlerts = False       '有同名工作簿直接覆盖
    ActiveWorkbook.SaveAs MyPath & "d:\数据\" & Date & "导出的数据" & ".XLS"
    ActiveWorkbook.Close                    '关闭新表
    Application.DisplayAlerts = True        '恢复警告
    Application.ScreenUpdating = True
End Sub

导出2个表的数据.rar

11.56 KB, 下载次数: 85

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2011-9-14 08:58 | 显示全部楼层
两张或多张相邻的工作表 单击第一张工作表的标签,然后在按住 Shift 的同时单击要选择的最后一张工作表的标签。
两张或多张不相邻的工作表 单击第一张工作表的标签,然后在按住 Ctrl 的同时单击要选择的其他工作表的标签。
然后再右键,移动或复制工作表,在出来的对话框里选新工作簿,勾选建立副本。
回复

使用道具 举报

 楼主| 发表于 2011-9-14 09:01 | 显示全部楼层
虽然没解决我的问题,但也要谢谢!
回复

使用道具 举报

发表于 2011-9-14 09:19 | 显示全部楼层
怎么没有解决?
回复

使用道具 举报

发表于 2011-9-14 09:36 | 显示全部楼层    本楼为最佳答案   
本帖最后由 zjdh 于 2011-9-14 09:43 编辑

注意红色语句:

'导出2个表的数据
Sub daochu2()
    Dim fso As Scripting.FileSystemObject
    Dim myFolder As String
    Application.ScreenUpdating = False
    lr = 10
    lr1 = 20
    With ThisWorkbook
        Workbooks.Add (1)
        .Sheets(1).Range("A2:E" & lr).Copy
        ActiveSheet.Paste
        ActiveWorkbook.Sheets.Add
        .Sheets(2).Range("A2:E" & lr1).Copy
        ActiveSheet.Paste
    End With
    myFolder = "d:\数据"
    Set fso = New Scripting.FileSystemObject
    If fso.FolderExists(myFolder) Then    '如果该文件夹已经存在
        Call 导出数据
    Else
        fso.CreateFolder myFolder       '如果没有指定的文件夹就创建文件夹
        Call 导出数据
    End If
    Set fso = Nothing
    Application.ScreenUpdating = True
    MsgBox "数据已被导出,保存在D:\数据\...", 48, "导出提示"
End Sub
Sub 导出数据()
    Application.DisplayAlerts = False       '有同名工作簿直接覆盖
    ActiveWorkbook.SaveAs MyPath & "d:\数据\" & Date & "导出的数据" & ".XLS"
    ActiveWorkbook.Close                    '关闭新表
    Application.DisplayAlerts = True        '恢复警告
    Application.ScreenUpdating = True
End Sub

回复

使用道具 举报

 楼主| 发表于 2011-9-14 20:22 | 显示全部楼层
谢谢5楼高手的代码,符合要求啦!
回复

使用道具 举报

发表于 2016-6-8 19:31 | 显示全部楼层
zjdh 发表于 2011-9-14 09:36
注意红色语句:

'导出2个表的数据

这个程序正好适用于我,但请问怎么去公式呢?,
回复

使用道具 举报

发表于 2016-6-9 14:02 | 显示全部楼层

ActiveSheet.Paste
改成
ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues
回复

使用道具 举报

发表于 2016-6-9 15:48 | 显示全部楼层
zjdh 发表于 2016-6-9 14:02

ActiveSheet.Paste
改成

谢谢,我已经学会并记住了。
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 10:21 , Processed in 0.317594 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表