vba--分拆工作薄

Sub 分拆工作薄()
'分拆工作薄到当前文件夹
Dim sht As Worksheet

Dim MyBook As Workbook
Application.DisplayAlerts = False '表示不显示警告
Set MyBook = ActiveWorkbook

For Each sht In MyBook.Sheets

sht.Copy

ActiveWorkbook.SaveAs Filename:=MyBook.Path & "\" & sht.Name, FileFormat:=xlNormal '将工作簿另存为EXCEL默认格式

ActiveWorkbook.Close

Next
Application.DisplayAlerts = True '表示不恢复警告
MsgBox "文件已经被分拆完毕!"

End Sub

'分拆工作薄到指定文件夹
Sub cffbbb()

Application.ScreenUpdating = False

Dim sht11 As Worksheet
Dim sht, sht1 As Worksheet
Dim k, i, j As Integer
Dim irow As Integer '这个说的是一共多少行
Dim l As Integer

l = 2 '第几列

'删除无意义的表
Application.DisplayAlerts = False
If Sheets.Count > 1 Then
    For Each sht1 In Sheets
        If sht1.Name <> "S房客带" Then
            sht1.Delete
        End If
    Next
End If

irow = Sheet1.Range("a65536").End(xlUp).Row
'拆分表
For i = 2 To irow
    k = 0
    For Each sht In Sheets
        If sht.Name = Sheet1.Cells(i, l) Then
            k = 1
        End If
    Next

    If k = 0 Then
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = Sheet1.Cells(i, l)
    End If

Next
'拷贝数据

For j = 2 To Sheets.Count
    Sheet1.Range("a1:ao" & irow).AutoFilter Field:=l, Criteria1:=Sheets(j).Name
    Sheet1.Range("a1:ao" & irow).Copy Sheets(j).Range("a1")

Next
For Each sht11 In Sheets
    If sht11.Name <> "S房客带" Then
    sht11.Copy
    ActiveWorkbook.SaveAs Filename:="d:\datc\" & sht11.Name & ".xlsx"   '执行程序前在d盘中新建问价夹datc  ********************************
    ActiveWorkbook.Close
    End If
Next
If Sheets.Count > 1 Then
    For Each sht2 In Sheets
        If sht2.Name <> "S房客带" Then
            sht2.Delete
        End If
    Next
End If

Application.DisplayAlerts = True
Sheet1.Range("a1:f" & irow).AutoFilter

Sheet1.Select

MsgBox "已处理完毕。"

End Sub