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