VBA拆分工作表代码

Sub Dan()

    Dim dataSRow&, strName$

    Dim Dic, Dk, strCol

    Dim i&, iRow&

    Application.DisplayAlerts = 0

    '参数调整区域

    strCol = "D"      '要拆分的字段所在的列号

    dataSRow = 2      '非标题行的数据起始行

    strName = "数据源" '数据源所在表表名

    '代码运行区域

    Set Dic = CreateObject("scripting.dictionary")

    With Sheets(strName)

        iRow = .Cells(.Rows.Count, strCol).End(3).Row

        '默认A1为数据起始单元格

        For i = dataSRow To iRow Step 1

            Dic(CStr(.Cells(i, strCol).Value)) = ""

        Next

        If Dic.Count = 0 Then

            MsgBox "无内容"

            Set Dic = Nothing

            Exit Sub

        End If

        Dk = Dic.keys

        For i = LBound(Dk) To UBound(Dk)

            On Error Resume Next

            Sheets(CStr(Dk(i))).Delete

            On Error GoTo 0

            Sheets(strName).Copy after:=Sheets(strName)

            With ActiveSheet

                .Name = Dk(i)

                iRow = .Cells(.Rows.Count, strCol).End(3).Row

                For k = iRow To dataSRow Step -1

                    If CStr(.Cells(k, strCol).Value) <> CStr(Dk(i)) Then

                        Cells(k, strCol).EntireRow.Delete

                    End If

                Next

            End With

        Next

        Application.DisplayAlerts = 1

    End With

    Set Dic = Nothing

    MsgBox "拆分完成"

End Sub