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
