VBA Excel导出某个Range范围的字符到另一个Excel

glk17

VBA Excel导出某个Range范围的字符到另一个Excel

目前用的代码是：

1. Sub 导出()
   
2. 
   
3. Dim jcsj_App As Excel.Application
   
4. Dim jcsj_Book As Excel.Workbook
   
5. Dim jcsj_Sheet As Excel.Worksheet
   
6. 
   
7. '启动Excel
   
8. Set jcsj_App = CreateObject("Excel.Application") '引用程序对象实例
   
9. 
   
10. '设置Excel为不可见
    
11. jcsj_App.Visible = False
    
12. 
    
13. '打开文件
    
14. Set jcsj_Book = jcsj_App.Workbooks.Open(Application.ActiveWorkbook.Path & "\sss.xlsx") '工作簿实例
    
15. Set jcsj_Sheet = jcsj_Book.Worksheets(1)
    
16. jcsj_Book.Worksheets(1).Activate
    
17. 
    
18. 'ycyln 异常已录入条数
    
19. ycyln = Worksheets("异常").Range("B65536").End(xlUp).Row - 100
    
20. 
    
21. jcsj_Book.Worksheets(1).Cells.Clear
    
22. Worksheets("异常").Range("B101:P" & ycyln + 100).Copy
    
23. jcsj_Book.Worksheets(1).Range("A1:O" & ycyln).PasteSpecial Paste:=xlPasteValues
    
24. 
    
25. jcsj_Book.Close SaveChanges:=True
    
26. jcsj_App.Quit
    
27. 
    
28. MsgBox "临时异常数据 导出完毕！"
    
29. 
    
30. End Sub
    

复制代码

Worksheets("异常").Range("B101:P" & ycyln + 100).Copy
jcsj_Book.Worksheets(1).Range("A1:O" & ycyln).PasteSpecial Paste:=xlPasteValues
的问题在于，导出的内容带了部分格式，譬如字体，底色，但是公式的部分，确实是复制的字符出来，当然单元格宽没有带出来

除了这种方法，其他试过很多，都是报错
譬如这个，报400错误

1. Worksheets("异常").Range("B101:P" & ycyln + 100).Copy
   
2. jcsj_Book.Worksheets(1).Activate
   
3. jcsj_Book.Worksheets(1).Range("A1:O" & ycyln).PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True

复制代码

请教，想仅导出字符和数值的话，代码如何修改
谢谢了

魂断蓝桥

复制-选择性粘贴-值

行不行

glk17

魂断蓝桥 发表于 2019-3-15 13:35
复制-选择性粘贴-值

行不行

嗯，试过

主要问题是跨Excel，VBA宏录制看不出来有用的代码
选择性粘贴，仅数值，录出来

1. Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
   
2.         :=False, Transpose:=False

复制代码

.PasteSpecial Paste:=xlPasteValues 就是简略版的，写全就报错

魂断蓝桥

glk17 发表于 2019-3-15 14:04
嗯，试过

主要问题是跨Excel，VBA宏录制看不出来有用的代码

Workbooks.Open ThisWorkbook.Path & "\1.xls"
    Sheets(1).Activate
    Cells.Clear
    ThisWorkbook.Sheets("Sheet5").Range("A1:C5").Copy
   Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
    Workbooks("1.xls").Close 1

glk17

魂断蓝桥 发表于 2019-3-15 14:38
Workbooks.Open ThisWorkbook.Path & "\1.xls"
    Sheets(1).Activate
    Cells.Clear

感谢帮助

4楼代码小改动后测试OK

1. Workbooks.Open ThisWorkbook.Path & "\sss.xlsx"
   
2. Sheets(1).Activate
   
3. Sheets(1).Cells.Clear
   
4. ThisWorkbook.Worksheets("异常").Range("A1:C5").Copy
   
5. Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
   
6. Workbooks("sss.xlsx").Close 1

复制代码

但如果改成重新打开一个Excel Application的话，还是跟之前一样，会把格式带过来

1. Dim jcsj_App As Excel.Application
   
2. Dim jcsj_Book As Excel.Workbook
   
3. Dim jcsj_Sheet As Excel.Worksheet
   
4. 
   
5. '启动Excel
   
6. Set jcsj_App = CreateObject("Excel.Application") '引用程序对象实例
   
7. 
   
8. '设置Excel为不可见
   
9. jcsj_App.Visible = True
   
10. 
    
11. '打开文件
    
12. Set jcsj_Book = jcsj_App.Workbooks.Open(ThisWorkbook.Path & "\sss.xlsx") '工作簿实例
    
13. 
    
14. 'ycyln 异常已录入条数
    
15. ycyln = Worksheets("异常").Range("B65536").End(xlUp).Row - 100
    
16. 
    
17. jcsj_Book.Worksheets(1).Cells.Clear
    
18. jcsj_Book.Sheets(1).Activate
    
19. ThisWorkbook.Worksheets("异常").Range("B101:P" & ycyln + 100).Copy
    
20. jcsj_Book.Worksheets(1).Range("A1:O" & ycyln).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
    
21. 
    
22. 
    
23. jcsj_Book.Close SaveChanges:=True
    
24. jcsj_App.Quit

复制代码

glk17

上传一下一楼问题的附件
test.rar (20.45 KB, 下载次数: 0)

2019-3-19 15:46 上传

点击文件名下载附件

range.value = range.value的方式，仅复制数值

运行正常，保存时有如下报警告：

1. Sub 导出()
   
2. 
   
3. Application.ScreenUpdating = False  '禁用刷新
   
4. 
   
5. Call Sheet6.整理
   
6. 
   
7. 'ycyln 异常已录入条数
   
8. ycyln = Worksheets("异常").Range("B65536").End(xlUp).Row - 100
   
9. 
   
10. aa = ActiveWorkbook.Name
    
11. bb = ActiveSheet.Name
    
12. 
    
13. Workbooks.Open Filename:=ThisWorkbook.Path & "\临时异常数据.xlsx"
    
14. Sheets(1).Activate
    
15. Sheets(1).Cells.Clear
    
16. 
    
17. Workbooks("临时异常数据.xlsx").Worksheets(1).Range("A1:O" & ycyln).Value = Workbooks(aa).Worksheets(bb).Range("B101:P" & ycyln + 100).Value
    
18. ActiveWorkbook.Save
    
19. ActiveWindow.Close
    
20. 
    
21. Application.ScreenUpdating = True  '刷新
    
22. 
    
23. MsgBox "临时异常数据 导出完毕！"
    
24. 
    
25. End Sub

复制代码