呼唤VBA高手帮忙制作分数发放条

bluewindeva · 发表于 2010-8-3 10:36

因工作需要每个季度需要制作分数明细表给个相关科室，希望在总表中检索出各科室，将每个科室的分数作为一个表格，单独导出成为一个新建的excel文件。希望高手帮忙，谢谢！
表格内容在附件中

[ 本帖最后由 bluewindeva 于 2010-8-3 10:50 编辑 ]

LangQueS · 发表于 2010-8-3 10:45

建议楼主在论坛搜索“工资条”相关主题……

参考：

单行和双行工资条 http://club.excelhome.net/dispbb ... &star=1#1513753

guojianlin1985 · 发表于 2010-8-3 10:46

好像不是很难啊，有时间给你做

bluewindeva · 发表于 2010-8-3 10:48

谢谢楼上的兄弟了

bluewindeva · 发表于 2010-8-3 10:49

因为本人是个VBA门外汉，目前想解决这个问题，所以希望会做的朋友帮忙做出来，谢谢了

dsmch · 发表于 2010-8-3 10:56

原帖由 bluewindeva 于 2010-8-3 10:49 发表
因为本人是个VBA门外汉，目前想解决这个问题，所以希望会做的朋友帮忙做出来，谢谢了

试试自动筛选

bluewindeva · 发表于 2010-8-3 11:03

还需要每行+标题行另存为一个新文件，并打印出来
好像自动筛选不能完成这些批量动作吧

LangQueS · 发表于 2010-8-3 11:28

请参考：

Sub 另存() '每行另存独立文件到默认目录
Application.DisplayAlerts = False '禁用警告框
Application.ScreenUpdating = False                '关闭屏幕刷新
Sheets.Add After:=Sheets(Sheets.Count) '在最后建立新表
a = Application.Sheets.Count
y = Sheets("分数").Columns(1).Find("*", , xlValues, , , 2).Row '第1列最后可见非空单元行号
For i = 3 To y
Sheets("分数").Select
Sheets(a).Name = Sheets("分数").Range("a" & i).Value '重新指定表名称
Sheets(a).Range("1:2") = Sheets("分数").Range("1:2").Value
Sheets(a).Range("3:3") = Sheets("分数").Range(i & ":" & i).Value
Sheets(a).Select
ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & ".xls" '以当前工作表名称为文件名称另存表2
ActiveWorkbook.Close          '退出当前文件（另存后的文件）
Sheets("分数").Select
Next
Sheets(a).Delete
Application.ScreenUpdating = True                '打开屏幕刷新
Application.DisplayAlerts = True '恢复警告框
End Sub

LangQueS · 发表于 2010-8-3 11:38

连同复制格式：

Sub 另存() '每行另存独立文件到默认目录
Application.DisplayAlerts = False '禁用警告框
Application.ScreenUpdating = False                '关闭屏幕刷新
Sheets.Add After:=Sheets(Sheets.Count) '在最后建立新表
a = Application.Sheets.Count
y = Sheets("分数").Columns(1).Find("*", , xlValues, , , 2).Row '第1列最后可见非空单元行号
For i = 3 To y
Sheets("分数").Select
Sheets(a).Name = Sheets("分数").Range("a" & i).Value '重新指定表名称
Sheets("分数").Rows("1:2").Copy Sheets(a).Rows("1:2")
Sheets("分数").Rows(i & ":" & i).Copy Sheets(a).Rows("3:3")
Sheets(a).Select
ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & ".xls" '以当前工作表名称为文件名称另存
ActiveWorkbook.Close          '退出当前文件（另存后的文件）
Next
Sheets("分数").Select
Sheets(a).Delete
Application.ScreenUpdating = True                '打开屏幕刷新
Application.DisplayAlerts = True '恢复警告框
End Sub

bluewindeva · 发表于 2010-8-3 11:40

谢谢版主大哥的帮忙了～就是我想要的结果，不知道还需要添加什么语句让新生成的表格自动有边框，还有格式和源格式相同呢？谢谢了

		自动登录	找回密码
密码			免费注册

[求助] 呼唤VBA高手帮忙制作分数发放条

回复 3楼 guojianlin1985 的帖子

回复 2楼 LangQueS 的帖子

回复 6楼 dsmch 的帖子

回复 8楼 LangQueS 的帖子

最新热点 /1