导出指定工作表指定区域数据（不含公式，只有值）

Lee_Ericbier

请教大侠，试了好多种办法一直没实现，不是带格式就是整个工作表复制 ，所以一直困惑，特请大侠赐教！！！！


见附件：在sheet1中单击“导出数据”，则出现选择保存目录、名称、类型等，即将sheet2表中A3：F15区域的数据导出到新的工作簿中，完成后关闭新工作簿。

            注意，F列有公式，导出的时候只保留值即可，不要公式，同时所有的格式都不需要。



求助.rar (7.64 KB, 下载次数: 43)

2014-11-7 21:29 上传

点击文件名下载附件

黄金万两︶ㄣ

附件。。。

黄金万两︶ㄣ

代码。。。

1. Sub 导出到新工作薄()
   
2. Application.ScreenUpdating = False
   
3. Dim arr, wb As Workbook
   
4. With Sheet2
   
5.     arr = .UsedRange
   
6. End With
   
7. Set wb = Workbooks.Add
   
8. With wb
   
9.     With .Sheets(1)
   
10.         .Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
11.     End With
    
12.     .SaveAs ThisWorkbook.Path & "\导出的数据后的工作薄.xls"
    
13.     .Close
    
14. End With
    
15. Set wb = Nothing
    
16. Application.ScreenUpdating = True
    
17. End Sub
    

复制代码

Lee_Ericbier

黄金万两︶ㄣ 发表于 2014-11-7 22:26
代码。。。

已解决，非常感谢！！！

黄金万两︶ㄣ

或者又试试这个

黄金万两︶ㄣ

代码。。。

1. Sub 导出到新工作薄()
   
2. Application.ScreenUpdating = False
   
3. Dim arr, wb As Workbook, nae$
   
4. nae = Dir(ThisWorkbook.Path & "\导出的数据后的工作薄.xls")
   
5. With Sheet2
   
6.     arr = .UsedRange
   
7. End With
   
8. If nae = "" Then
   
9.     Set wb = Workbooks.Add
   
10. Else
    
11.     Set wb = Workbooks.Open(ThisWorkbook.Path & "\导出的数据后的工作薄.xls")
    
12. End If
    
13. With wb
    
14.     With .Sheets(1)
    
15.         x = .Cells(.Rows.Count, 1).End(3).Row
    
16.         .Cells(x, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
    
17.     End With
    
18.     If nae = "" Then
    
19.         .SaveAs ThisWorkbook.Path & "\导出的数据后的工作薄.xls"
    
20.     Else
    
21.         .Save
    
22.     End If
    
23.     .Close
    
24. End With
    
25. Set wb = Nothing
    
26. Application.ScreenUpdating = True
    
27. End Sub
    
28. 
    

复制代码

黄金万两︶ㄣ

看到这句x = .Cells(.Rows.Count, 1).End(3).Row 换成 x = .Cells(.Rows.Count, 1).End(3).Offset(1).Row

xiexinxi

Sub 导出到新工作薄()
Application.ScreenUpdating = False
Dim arr, wb As Workbook, key, dz, dzz
dzz = Cells(4, 12)
key = InputBox("请输入文件名", "某某公司名称", dzz)
If Len(key) > 0 And key <> "" Then
dz = "\" & key & ".xls"
With Sheet5
    arr = .UsedRange
End With
Set wb = Workbooks.Add
With wb
    With .Sheets(1) '目标表名不能更改
        .Range("a1").Resize(UBound(arr), UBound(arr, 2) - 4) = arr '-4为最尾列减4列的意思
        .Application.DisplayAlerts = False '直接覆盖不提示
    End With
    .SaveAs ThisWorkbook.Path & dz
    .Close
End With
Set wb = Nothing
Application.ScreenUpdating = True
Else
End If
MsgBox "文件导出成功！文件名为：" & dz & ""
End Sub

wangds-2007

黄金万两︶ㄣ 发表于 2014-11-7 22:57
代码。。。

导出的工作表能否格式不变？

aliensky

学习~~~~~~，感谢