如何根据计划模板生成目标工作薄多工作表样式

yzyyyyyyy

源代码工作簿中，有一个固定的模板工作表，以模板为蓝本，其中F1为变化单元格。
复制该模板工作表，建立另一新的工作薄。
根据F1的变化，生成多张工作表，其中的工作表命名规则为F1单元格的值。
保存新的工作薄。样表中有2个工作表。 如何根据计划模板生成目标工作薄多工作表样式20161129.rar (21.96 KB, 下载次数: 92)

2016-11-29 14:04 上传

点击文件名下载附件

yzyyyyyyy

Sub 按模板生成工作表()
    Application.ScreenUpdating = False
        Application.DisplayAlerts = False
    Dim wb As Workbook
    Set sht = ActiveSheet
    Sheets("模板").[F1] = ""
    Set wb = Workbooks.Add
    For i = 1 To 2
       [F1] = i
        sht.Activate
        Sheets("模板").Copy after:=wb.Worksheets(wb.Worksheets.Count)
        ActiveSheet.Name = [F1] & "班"
        sht.Activate
    Next
    For Each sh In wb.Worksheets  '删除多余工作表
        If Not sh.Name Like "*班" Then sh.Delete
    Next
    wb.SaveAs ThisWorkbook.Path & "\成品.xls"
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

ykqrs

1. Sub qq()
   
2. Dim wb As Workbook, arr, nm$, sht As Worksheet
   
3. With ActiveSheet
   
4. nm = .[f1] & "班"
   
5. Set wb = Workbooks.Open(ThisWorkbook.Path & "/成品表.xls")
   
6. .Copy after:=wb.Sheets(Sheets.Count)
   
7. For Each sht In wb.Sheets
   
8. Application.DisplayAlerts = False
   
9. If sht.Name = nm Then sht.Delete
   
10. Next
    
11. wb.Sheets(Sheets.Count).Name = nm
    
12. wb.Sheets(nm).DrawingObjects.Delete
    
13. wb.Close True
    
14. End With
    
15. End Sub

复制代码

ykqrs

如何根据计划模板生成目标工作薄多工作表样式20161129.rar (31.55 KB, 下载次数: 128)

2016-11-29 14:55 上传

点击文件名下载附件

chxw68

1. Sub 按模板生成工作表()
   
2.   Dim r%, i%
   
3.   Dim wb As Workbook
   
4.   Dim sht As Worksheet
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Application.SheetsInNewWorkbook = 2
   
8.   Set wb = Workbooks.Add
   
9.   With wb
   
10.     For i = 1 To 2
    
11.       With .Worksheets(i)
    
12.         .Name = i & "班"
    
13.         ThisWorkbook.Worksheets("模板").UsedRange.Copy Destination:=.Range("a1")
    
14.         .Range("f1") = i
    
15.       End With
    
16.     Next
    
17.     .SaveAs ThisWorkbook.Path & "\成品.xls", FileFormat:=xlExcel8
    
18.     .Close False
    
19.   End With
    
20.   Application.ScreenUpdating = True
    
21.   Application.DisplayAlerts = True
    
22. End Sub

复制代码

chxw68

1. Sub 按模板生成工作表2()
   
2.   Dim r%, i%
   
3.   Dim wb As Workbook
   
4.   Dim sht As Worksheet
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Application.SheetsInNewWorkbook = 1
   
8.   Set wb = Workbooks.Add
   
9.   With wb
   
10.     For i = 1 To 2
    
11.       ThisWorkbook.Worksheets("模板").Copy after:=wb.Worksheets(Worksheets.Count)
    
12.       With .ActiveSheet
    
13.         .Name = i & "班"
    
14.         .Range("f1") = i
    
15.         For Each shap In .Shapes
    
16.           shap.Delete
    
17.         Next
    
18.       End With
    
19.     Next
    
20.     .Worksheets("sheet1").Delete
    
21.     .SaveAs ThisWorkbook.Path & "\成品.xls", FileFormat:=xlExcel8
    
22.     .Close False
    
23.   End With
    
24.   Application.ScreenUpdating = True
    
25.   Application.DisplayAlerts = True
    
26. End Sub
    

复制代码

chxw68

详见附件。

lsc900707

yzyyyyyyy 发表于 2016-11-29 14:49
Sub 按模板生成工作表()
    Application.ScreenUpdating = False
        Application.DisplayAlerts =  ...

Sub 按模板生成工作表()
  Dim wb As Workbook
  Dim sh As Worksheet
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set wb = Workbooks.Add
  With wb
    For i = 1 To 2
      ThisWorkbook.Worksheets("模板").Copy after:=wb.Worksheets(Worksheets.Count)
      With .ActiveSheet
        .Name = i & "班"
        .[f1] = i
      End With
    Next
    For Each sh In wb.Worksheets  '删除多余工作表
         If Not sh.Name Like "*班*" Then sh.Delete
     Next
    .SaveAs ThisWorkbook.Path & "\成品", FileFormat:=xlExcel8
    .Close False
  End With
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

lsc900707

参考附件>>>>>>>>>>
网络故障，附件上传失败，楼下有重新上传

lsc900707

参考附件>>>>>>>>>>