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

bluewindeva

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

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

LangQueS

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

参考：

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

guojianlin1985

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

bluewindeva

谢谢楼上的兄弟了

bluewindeva

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

dsmch

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

试试自动筛选

bluewindeva

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

LangQueS

请参考：

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

连同复制格式：

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

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