本帖最后由 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