VBA 指定字段拆分工作表(筛选)

Excel VBA练习 2021-08-05

2825

工作表不是拆就是合,今天我们来练习下筛选法指定字段名拆分工作表

示例文件下载
链接：https://pan.baidu.com/s/1iuOwrstpMH2zwBSX_ZIpkQ
提取码：abcd

关注公众号 ↓

如下图所示

现需要按照任意字段来拆分工作表

根据数据源,可以是按照序号,地区,公司名称等来拆分

代码如下

Sub Sht_Fiter() '筛选拆分
    Dim Sht As Worksheet, ActSht As Worksheet
    Dim Dic, Mat, aData, T
    Dim x&, y&, iCol&, iRow&
    Dim strErr$, strMsg$, s$, strShtName
    Dim Rng As Range, Cell As Range
    On Error Resume Next
    Set ActSht = ActiveSheet '当前工作表
'    Application.DisplayAlerts = False
'    For Each Sht In Worksheets '删除除当前工作表以外的工作表
'        If Sht.Name <> ActSht.Name Then
'            Sht.Delete
'        End If
'    Next
'    Application.DisplayAlerts = True
    With ActSht
        If Not IsEmpty(.UsedRange) = False Then MsgBox "当前为空表,无法拆分!!", 64, "提示!": Exit Sub '空表不执行程序
        If .AutoFilterMode = True Then .ShowAllData '存在筛选则展开所有内容
        Set Rng = 模块.SetRng("选择需要拆分的所在列" & Chr(10) & "注意:只能选取一列作为拆分依据")
        If Rng Is Nothing Then MsgBox "请重新选择", 64, "提示": Exit Sub
        If Rng.Columns.Count > 1 Then MsgBox "只能选择一列,太多了干不过来~~", 64, "提示": Exit Sub
        iRow = 模块.SetRow("请选择标题的行数,不能为负数")
        If iRow < 0 Then MsgBox "只能是大于0的正数", 64, "提示!": Exit Sub
        T = Timer
        Set Cell = .UsedRange '获取当前工作表的全部内容
        aData = Cell.Value '存入数组
        Set Dic = CreateObject("Scripting.Dictionary") '后期绑定字典
        y = Rng.Column - Cell.Column + 1 '实际需要拆分的所在列位置
        For x = iRow + 1 To UBound(aData)
            Dic(aData(x, y)) = "" '实际拆分列的数据作为关键字存入字典
        Next
        Call 模块.AppEx '屏蔽弹窗闪屏等设置
        Cell.AutoFilter '进入筛选状态
        For Each Mat In Dic.keys '遍历字典中所有的Key
            strShtName = Mat
            If IsDate(strShtName) Then strShtName = Split(strShtName, " ")(0)
            Cell.AutoFilter field:=y, Criteria1:=strShtName '筛选条件
            If strShtName = "" Then
                strShtName = "空"
            ElseIf IsDate(strShtName) Then
                strShtName = Format(strShtName, "yyyy-mm-dd")
            End If
            Set Rng = .UsedRange '获取筛选后全部的内容
            With Sheets.Add(after:=Sheets(Sheets.Count))
                .Name = strShtName
            End With
            If Err Then '如果出错
                Err.Clear
                ActiveSheet.Delete '删除当前表
                strErr = strErr & Chr(10) & strShtName  '记录错误信息
            Else
                strMsg = strMsg & Chr(10) & strShtName
                Rng.Copy Worksheets(strShtName).Range("a1") '没错则复制内容至新表中
                Worksheets(strShtName).Columns.AutoFit
            End If
            .Select '回到当前表
        Next
        .UsedRange.AutoFilter '当前工作表取消筛选
    End With
    If strMsg <> "" Then s = "成功创建以下工作表:" & Chr(10) & Mid(strMsg, 2)
    If strErr <> "" Then s = s & Chr(10) & Chr(10) & "您为工作表或图标输入的名称无效。请确保:" & Chr(10) _
                            & "※名称不多于31个字符。" & Chr(10) _
                            & "※名称不包含下列任一字符:\/?*[或]。" & Chr(10) _
                            & "※名称不为空。" & Chr(10) _
                            & "创建失败名称如下 " & Chr(10) & Mid(strErr, 2)
    MsgBox s & Chr(10) & "总共花费了:" & Format(Timer - T, "0.0000秒")
    Call 模块.AppEx(True) '恢复系统设置
    Set Dic = Nothing '释放字典内存
End Sub