用VBA复制工作表到新工作簿中

cellolose

zengxp 发表于 2013-1-31 22:26
不明白你的意思， 如果仅是选择性粘贴，图片是无法复制过去的，而且经过赋值的处理已经没有公式；
批量的 ...

1不需要图片复制过去，如果可以的话只复制A1：G3表格部分即可。所以能够实现选择性粘贴的话最好不过了。

2新生成的工作簿是存放在当前文件夹中的。不需要查找整个电脑所有的盘符，那样不现实。

3如果在当前文件夹中存在重名工作簿，能不能不替换它（现在的问题就是它会替换，而不是我想要的复制新工作表副本到新工作簿中），在保留原工作簿里的工作表的基础上，复制一张新的工作表副本到新工作簿中。
你说的已有工作薄里的内容我是希望完全保留，复制来的数值要粘贴到新工作表里？

cellolose

是我表达不够清楚。
我做个样例出来吧：
我是想通过例如附件中“源.xls”这样的工作簿，生成“张三.xls”、“李四.xls”、“王五.xls”这样的档案工作簿。
因为数据源有上千条记录，表格也不是怎么简单，要为每个人建立个人各个时期、科目的档案，所以很麻烦。
所以还要麻烦多多费心了。 样例.rar (20.6 KB, 下载次数: 80)

2013-2-1 03:43 上传

点击文件名下载附件

zengxp

复制 A1：G3 区域， 不是用你的方法做的，测试可行
运行程序前先备份

cellolose

zengxp 发表于 2013-2-1 13:06
复制 A1：G3 区域， 不是用你的方法做的，测试可行
运行程序前先备份

1. 
   
2. Private Sub CommandButton2_Click()
   
3.    
   
4.     Dim wb As Workbook
   
5.     Set y = CreateObject("Scripting.FileSystemObject")
   
6. 
   
7.     Application.DisplayAlerts = False
   
8.     Application.ScreenUpdating = False
   
9. 
   
10. 
    
11.     Sheets.Add after:=Sheets(Sheets.Count)
    
12.     Set She = Sheets(Sheets.Count)
    
13.    
    
14.     Set Sht = Sheet9 '所需要复制的工作表
    
15.     Sht.Cells.Copy '格式刷整个表格格式到目标表格
    
16.     She.Cells.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    
17.     SkipBlanks:=False, Transpose:=False
    
18.     She.Range("AC2:AD5").ClearFormats   '清除表格式（注意范围）
    
19.     Application.CutCopyMode = False
    
20.    
    
21.     ActiveWindow.DisplayZeros = False   '清除全表零值显示
    
22. 
    
23. 
    
24. 
    
25.         For i = [AD4] To [AD5]   '通过开始行号、结束行号控制运行保存范围
    
26.             Sht.Activate
    
27.             [AD2] = i
    
28.             Sht.Range("A1:AB43").Copy '选择复制范围（注意范围）
    
29.    
    
30.             She.Select
    
31.             She.Range("A1").Select
    
32.             Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
    
33.                 xlNone, SkipBlanks:=False, Transpose:=False
    
34.             Application.CutCopyMode = False
    
35. 
    
36.                     
    
37.             ActiveSheet.Name = [J31].Value   '赋值当前工作表名（指定单元格）
    
38.             wbName = ThisWorkbook.Path & Application.PathSeparator & [C3].Value & ".xls"   '准备工作簿名赋值为单元格的值（指定单元格）
    
39. 
    
40.             If y.FileExists(wbName) Then                     '复制至已有工作簿中
    
41.                 Set wb = Workbooks.Open(wbName)
    
42.                 She.Copy Before:=wb.Sheets(Sheets.Count)
    
43.                 ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value  '保留单元格数值,去掉公式
    
44.                 wb.Close True
    
45.             Else                                             '复制生成新工作簿中
    
46.                 She.Copy
    
47.                 ActiveWorkbook.SaveAs wbName
    
48.                 ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value  '保留单元格数值,去掉公式
    
49.                 ActiveWorkbook.Close True
    
50.             End If
    
51. 
    
52.         Next
    
53.         
    
54.     Application.CutCopyMode = False
    
55.     She.Delete
    
56.    
    
57.     Application.DisplayAlerts = True
    
58.     Application.ScreenUpdating = True
    
59.     MsgBox "导出成功."
    
60.    
    
61. End Sub
    

复制代码

这个代码是“邮件合并”在excel中的实现，能生成个体表格。
学习了zengxp以及版主的一些代码
自己试着写了下，虽然代码不是最简洁最好的，但实现了自己想要的功能。

zengxp的代码设计中，先拷贝到了新建的最后的工作表中，开始我认为这个降低了运行的效率，可是后来发现这个设计很好，它避免了重命名文件重名情况下程序无法运行的现象，这里赞一个。

在此，感谢
蓝桥玄霜
zengxp
山菊花老师

zhangzhenxia

cellolose 发表于 2013-2-1 02:51
谢谢zengxp一直以来的帮助。

现在上传的这个附件实现了批量生成！

路过，学习了，谢谢！

zhangzhenxia

cellolose 发表于 2013-2-1 02:51
谢谢zengxp一直以来的帮助。

现在上传的这个附件实现了批量生成！

路过，学习了，谢谢！

yanyishui

学习了，谢谢！vba很深奥

无理大盗

谢谢zengxp一直以来的帮助。
正好有需要

DieciSeis

zengxp 发表于 2013-2-1 13:06
复制 A1：G3 区域， 不是用你的方法做的，测试可行
运行程序前先备份

请问如果根据工作表【表格】的【开始行号】[J4]和【结束行号】[J5]来进行批量新建工作表至新工作簿，请问VBA代码需要怎么调整的呢？？