20181013xlVba年级报表拆分为班级报表

'年级报表拆分为班级报表
Public Sub CreateClassReport()
    Application.DisplayAlerts = False
    
    Dim Wb As Workbook
    Dim OneSht As Worksheet
    Dim NewWb As Workbook
    Dim FolderPath As String
    Dim FilePath As String
    Dim FileName As String
    
    Dim Num
    
    Dim Dic As Object
    Set Wb = Application.ThisWorkbook
    Set Dic = CreateObject("Scripting.Dictionary")
    FolderPath = Wb.Path & ""
    
    For Each OneSht In Wb.Worksheets
        Num = RegGet(OneSht.Name, "(d*)")
        If Num <> "" Then
            Dic(Num) = ""
        End If
    Next OneSht
    For Each Num In Dic.keys
        FileName = Num & "班级报表.xlsx"
        On Error Resume Next
        Application.Workbooks(FileName).Close True
        On Error GoTo 0
        
        FilePath = FolderPath & FileName
        
        On Error Resume Next
        Kill FilePath
        On Error GoTo 0
        
        Set NewWb = Application.Workbooks.Add
        NewWb.SaveAs Num & ".xlsx"
        For Each OneSht In Wb.Worksheets
            If RegGet(OneSht.Name, "(d*)") = "" Or RegGet(OneSht.Name, "(d*)") = Num Then
                OneSht.Copy after:=NewWb.Worksheets(NewWb.Worksheets.Count)
            End If
        Next OneSht
        NewWb.Worksheets(1).Delete
        NewWb.Save
        NewWb.Close True
    Next Num
    
    Set Dic = Nothing
    Set Wb = Nothing
    Set NewWb = Nothing
    Set OneSht = Nothing
    
    Application.ScreenUpdating = True
    
End Sub

Public Function RegGet(ByVal OrgText As String, ByVal Pattern As String) As String
    Dim Regex As Object
    Dim Mh As Object
    Set Regex = CreateObject("VBScript.RegExp")
    With Regex
        .Global = True
        .Pattern = Pattern
    End With
    If Regex.test(OrgText) Then
        Set Mh = Regex.Execute(OrgText)
        RegGet = Mh.Item(0).submatches(0)
    Else
        RegGet = ""
    End If
    Set Regex = Nothing
End Function