20190102xlVBA_多表按姓名同时拆分

Sub 多表按姓名同时拆分20190102()
    AppSettings
    Dim StartTime As Variant
    Dim UsedTime As Variant
    StartTime = VBA.Timer
    On Error GoTo ErrHandler
    Dim fRng As Range
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim OneSht As Worksheet, OneName, OneKey
    Dim dic As Object, HeadRow, SplitCol, Staff
    Dim dName As Object
    Dim NewWb As Workbook
    Dim Newsht As Worksheet

    Set dic = CreateObject("Scripting.Dictionary")
    Set dName = CreateObject("Scripting.Dictionary")
    Set Wb = Application.ThisWorkbook
    
    
    For Each OneSht In Wb.Worksheets
        If OneSht.Visible = xlSheetVisible Then
            With OneSht
                If .FilterMode Then .Cells.AutoFilter
                'On Error Resume Next
                Set fRng = .UsedRange.Find("拆分姓名", , , xlPart)
                If fRng Is Nothing Then
                    dic(.Name) = "save"
                Else
                    info = fRng.Address(0, 0)
                    dic(.Name) = info
                    'Debug.Print "需要拆分的表格为 [" & .Name & "]"
                    SplitCol = RegGet(info, "(\D+)")
                    HeadRow = CLng(RegGet(info, "(\d+)"))
                    EndRow = .Cells(.Cells.Rows.Count, SplitCol).End(xlUp).Row
                    For i = HeadRow + 1 To EndRow
                        Staff = .Cells(i, SplitCol).Value
                        dName(Staff) = ""
                    Next i
                End If
            End With
        End If
    Next OneSht
    
    counter = 0
    For Each OneName In dName.Keys
        counter = counter + 1
        FileName = OneName & ".xlsx"
        FolderPath = Wb.Path & "\"
        FilePath = FolderPath & FileName
        Set NewWb = Application.Workbooks.Add
        On Error Resume Next
        Kill FilePath
        On Error GoTo 0
        NewWb.SaveAs FilePath
        For Each OneKey In dic.Keys
            Debug.Print "正在为 [" & OneName & "] 拆分工作表 [" & OneKey & " ]"
            If dic(OneKey) = "save" Then
                Set OneSht = Wb.Worksheets(OneKey)
                OneSht.Copy after:=NewWb.Worksheets(NewWb.Worksheets.Count)
                
            Else
                '进行拆分
                Set Newsht = NewWb.Worksheets.Add(after:=NewWb.Worksheets(NewWb.Worksheets.Count))
                Newsht.Name = OneKey
                
                Set OneSht = Wb.Worksheets(OneKey)
                info = dic(OneKey)
                SplitCol = RegGet(info, "(\D+)")
                
                HeadRow = CLng(RegGet(info, "(\d+)"))
                With OneSht
                    SplitNo = .Cells(1, SplitCol).Column
                    If .FilterMode = True Then .Cells.AutoFilter
                    EndCol = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByColumns, xlPrevious).Column
                    Set Rng = .Range("A" & HeadRow).Resize(1, EndCol)
                    Rng.AutoFilter Field:=SplitNo, Criteria1:=OneName
                    Set Rng = .UsedRange.SpecialCells(xlCellTypeVisible)
                    Rng.Copy Newsht.Range("A1")
                    If .FilterMode = True Then .Cells.AutoFilter
                End With
            End If
        Next OneKey
        
        NewWb.Save
        NewWb.Close True
        'If counter = 3 Then Exit For
    Next OneName
    
    Set dic = Nothing
    Set dName = Nothing
    Set Wb = Nothing
    Set NewWb = Nothing
    Set Sht = Nothing
    Set OneSht = Nothing
    Set Newsht = Nothing
    Set Rng = Nothing
    UsedTime = VBA.Timer - StartTime
    Debug.Print "UsedTime ：" & Format(UsedTime, "#0.0000 Seconds")
    MsgBox "共拆分" & counter & "人，用时 ：" & Format(UsedTime, "#0.00秒。")
ErrorExit:
    AppSettings False
    Exit Sub
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description & "！", vbCritical, "AuthorQQ 84857038"
        Debug.Print Err.Description
        Err.Clear
        Resume ErrorExit
    End If
End Sub
Private 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
Private Sub AppSettings(Optional IsStart As Boolean = True)
    Application.ScreenUpdating = IIf(IsStart, False, True)
    Application.DisplayAlerts = IIf(IsStart, False, True)
    Application.Calculation = IIf(IsStart, xlCalculationManual, xlCalculationAutomatic)
    Application.StatusBar = IIf(IsStart, ">>>>>>>>Macro Is Running>>>>>>>>", False)
End Sub