除某表外其它工作表删除

yjwdjfqb

除某表外其它工作表删除




把这一句，改成，生成的新工作薄，除 "模板"工作表外，其它工作表全部删除
除某表外删除.rar (14.25 KB, 下载次数: 4)

2018-6-15 11:48 上传

点击文件名下载附件

请老师们帮下忙，谢谢老师们了！

ruoyunruyan

1. Sub 拆分()
   
2. Dim arr
   
3. Dim wb As Workbook
   
4. Dim ws As Worksheet
   
5. Set ws = ThisWorkbook.Worksheets("模板")
   
6. arr = Worksheets("数据源").Range("A2:G3") '指定固定区域
   
7. Application.ScreenUpdating = False
   
8. Application.DisplayAlerts = False
   
9. For i = 1 To UBound(arr)
   
10. With ws
    
11. .Range("C2,E2,C3,E3,C4:E4,C5,E5").ClearContents '先消除模板中指定区域的内容；若有合并单元格时地址写法注意，如这里“C4:E4”就是合并单元格
    
12. .Range("C2") = arr(i, 2)
    
13. .Range("E2") = arr(i, 4)
    
14. .Range("C3") = arr(i, 3)
    
15. .Range("E3") = arr(i, 1)
    
16. .Range("C4") = arr(i, 5)
    
17. .Range("C5") = arr(i, 7)
    
18. .Range("E5") = arr(i, 6)
    
19. End With
    
20. ws.Copy
    
21. With ActiveWorkbook
    
22. .SaveAs Filename:=ThisWorkbook.Path & "" & arr(i, 2) '工作薄名称，以姓名列
    
23. .Close False
    
24. End With
    
25. Next
    
26. Application.ScreenUpdating = True
    
27. MsgBox "数据拆分完毕！"
    
28. ThisWorkbook.Worksheets("模板").Range("C2,E2,C3,E3,C4:E4,C5,E5").ClearContents '先消除模板中指定区域的内容；若有合并单元格时地址写法注意，如这里“C4:E4”就是合并单元格
    
29. End Sub

复制代码

yjwdjfqb

ruoyunruyan 发表于 2018-6-15 13:35

谢谢老师帮助！