zoukankan      html  css  js  c++  java
  • 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
    

      

  • 相关阅读:
    已知自然数A、B不互质,A、B最大公约数和最小公倍数之和为35,那么A+B的最小值是多少?
    mysql null字段 空字段 查询效率
    sql注入和网站攻击思路
    软件服务新时代:开源软件的盈利模式
    eclipse maven插件配置,jdk全局版本调整
    spring事务(isolation隔离级别,propagation事务传播属性)
    GBDT 算法
    博客园的 “随笔、文章、新闻、日记”有啥区别
    1.3 Java中的标识符和关键字
    1.1 Java 的概述
  • 原文地址:https://www.cnblogs.com/nextseven/p/10206982.html
Copyright © 2011-2022 走看看