另存所有工作表为单独工作簿（2）

最新推荐文章于 2024-09-22 11:17:00 发布

键盘上的GG小怪兽GG

最新推荐文章于 2024-09-22 11:17:00 发布

阅读量130

点赞数

文章标签：数据库

本文链接：https://blog.csdn.net/sforce/article/details/120546407

版权

Sub 分开存为工作薄()
Dim Sh As Worksheet
Dim Sh1 As Worksheet
Dim Wk As Workbook
Dim iPath As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False


iPath = ThisWorkbook.Path & "\"     '保存路径为当前工作簿所在路径

'将工作表分别复制到部门或基层工作薄中
For Each Sh In ThisWorkbook.Worksheets
   With Sh
     If Not (.Name Like "走访*") And Not (.Name Like "座谈*") And Not (.Name Like "统计*") Then
         Set Wk = Workbooks.Add
        .Copy before:=Wk.Worksheets("sheet1")
        
        '删除新建工作薄时，默认新建的工作表
        For Each Sh1 In Wk.Worksheets
            If Sh1.Name Like "*Sheet*" Then
               Sh1.Delete
            End If
        Next Sh1
        
     Wk.SaveAs iPath & .Name & ".xls"
     Wk.Close
     
     End If
    End With
Next


Set Wk = Nothing

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub