[已解决]能否根据汇总表批量生成一批打分表，小白求助

笑看天下

现在需要将基本情况表格里的内容对应贴到打分表里，并且按照打分表的格式命名（组号 类别 "打分表“），能否批量生成，望各位大神不吝赐教

最佳答案

月排行榜 / 总排行榜

sry660

2015-12-18 12:23

重新优化了下，总表扩展后也能正常使用

1. Sub 设置批量表()
   
2. Dim arr, i&, j&, Sht As Worksheet, Wb As Workbook
   
3. Application.DisplayAlerts = False
   
4. Application.ScreenUpdating = False
   
5. Sheets(1).Activate
   
6. arr = [a1].CurrentRegion
   
7. 
   
8. Sheets("模板").Copy after:=Sheets(Sheets.Count)
   
9. Set Sht = ActiveSheet
   
10. For i = 2 To UBound(arr)
    
11.     Sht.Name = arr(i, 1) & " " & arr(i, 2) & " 打分表"
    
12.     [b1] = arr(i, 1)
    
13.     [b2] = arr(i, 2)
    
14.     For j = 3 To UBound(arr, 2)
    
15.         Cells(j + 1, 1) = arr(i, j)
    
16.     Next
    
17.     Sht.Copy
    
18.     Set Wb = ActiveWorkbook
    
19.     Wb.SaveAs ThisWorkbook.Path & "" & Sht.Name & ".xlsx"
    
20.     Wb.Close True
    
21. Next
    
22. Sheets(3).Delete
    
23. Sheets(1).Select
    
24. Application.ScreenUpdating = True
    
25. Application.DisplayAlerts = True
    
26. End Sub

复制代码

跳转到最佳答案楼层

know

只要表头不要值？

不论要那样，都是可以的，只不过你的附件里没有效果说明，没办法给你做。

sry660

1. Sub 设置批量表()
   
2. Dim arr, i&, j&, Sht As Worksheet, Wb As Workbook
   
3. Application.DisplayAlerts = False
   
4. Application.ScreenUpdating = False
   
5. Sheets(1).Activate
   
6. arr = [a1].CurrentRegion
   
7. 
   
8. Sheets("模板").Copy after:=Sheets(Sheets.Count)
   
9. Set Sht = ActiveSheet
   
10. For i = 2 To UBound(arr)
    
11.     Sht.Name = arr(i, 1) & " " & arr(i, 2) & " 打分表"
    
12.     [b1] = arr(i, 1)
    
13.     [b2] = arr(i, 2)
    
14.     [a4] = arr(i, 3)
    
15.     [a5] = arr(i, 4)
    
16.     [a6] = arr(i, 5)
    
17.     [a7] = arr(i, 6)
    
18.     Sht.Copy
    
19.     Set Wb = ActiveWorkbook
    
20.     Wb.SaveAs ThisWorkbook.Path & "" & Sht.Name & ".xlsx"
    
21.     Wb.Close True
    
22. Next
    
23. Sheets(3).Delete
    
24. Sheets(1).Select
    
25. Application.ScreenUpdating = True
    
26. Application.DisplayAlerts = True
    
27. End Sub

复制代码

sry660

重新优化了下，总表扩展后也能正常使用

1. Sub 设置批量表()
   
2. Dim arr, i&, j&, Sht As Worksheet, Wb As Workbook
   
3. Application.DisplayAlerts = False
   
4. Application.ScreenUpdating = False
   
5. Sheets(1).Activate
   
6. arr = [a1].CurrentRegion
   
7. 
   
8. Sheets("模板").Copy after:=Sheets(Sheets.Count)
   
9. Set Sht = ActiveSheet
   
10. For i = 2 To UBound(arr)
    
11.     Sht.Name = arr(i, 1) & " " & arr(i, 2) & " 打分表"
    
12.     [b1] = arr(i, 1)
    
13.     [b2] = arr(i, 2)
    
14.     For j = 3 To UBound(arr, 2)
    
15.         Cells(j + 1, 1) = arr(i, j)
    
16.     Next
    
17.     Sht.Copy
    
18.     Set Wb = ActiveWorkbook
    
19.     Wb.SaveAs ThisWorkbook.Path & "" & Sht.Name & ".xlsx"
    
20.     Wb.Close True
    
21. Next
    
22. Sheets(3).Delete
    
23. Sheets(1).Select
    
24. Application.ScreenUpdating = True
    
25. Application.DisplayAlerts = True
    
26. End Sub

复制代码

笑看天下

sry660 发表于 2015-12-18 12:23
重新优化了下，总表扩展后也能正常使用

万分感谢大神的帮助，工作瞬间变得好简单