1. 如下Excel表，总共有120多行数据，如何将以50行数据为一个工作表进行拆分

Sub ZheFenSheet()

    Dim r, c, i, WJhangshu, WJshu, bt As Long

    r = Range("A" & Rows.Count).End(xlUp).Row

    b = InputBox("请输入分表行数")

    If IsNumeric(b) Then

           WJhangshu = Int(b)

        Else

            MsgBox "输入错误", vbOKOnly, "错误"

            End

    End If

    c = Cells(, Columns.Count).End(xlToLeft).Column

    bt =  '标题行数

    'WJhangshu = 50 '每个文件的行数

    WJshu = IIf(r - bt Mod WJhangshu, Int((r - bt) / WJhangshu), Int((r - bt) / WJhangshu) + )

    '------

    Set fs = CreateObject("Scripting.FileSystemObject") '

    For i =  To WJshu

        Workbooks.Add

        Application.DisplayAlerts = False

        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Format(i + , String(Len(WJshu), )) & "." & fs.GetExtensionname(ThisWorkbook.FullName)   '扩展名

        Application.DisplayAlerts = True

        ThisWorkbook.ActiveSheet.Range("A1").Resize(bt, c).Copy ActiveSheet.Range("A1")

        ThisWorkbook.ActiveSheet.Range("A" & bt + i * WJhangshu + ).Resize(WJhangshu, c).Copy _

        ActiveSheet.Range("A" & bt + )

        ActiveWorkbook.Close True

    Next

End Sub

' 如下Excel表  按照 XX 列 工作表进行拆分

' 第三列 任务负责人 ，关键字

' ******************************************

' -----------------------------------------

'  Str = Arr(i, 1)   '第一列 任务负责人 ，关键字

 Sub 如何将一个Excel工作表的数据拆分成多个工作表()

    Dim Arr, Rng As Range, Sht As Worksheet, Dic As Object

    Dim k, t, Str As String, i As Long, lc As Long

    Application.ScreenUpdating = False '关闭屏幕更新

    Arr = Range("A1").CurrentRegion.Value

    lc = UBound(Arr, ) '求取最后一列的列号

    Set Rng = Rows() '标题行

    Set Dic = CreateObject("Scripting.Dictionary") '创建字典

    For i =  To UBound(Arr)

        '-----------------------------------------

        Str = Arr(i, ) '第一列 拆分 订单号，关键字

        '-----------------------------------------

        If Not Dic.Exists(Str) Then '如果字典没有关键字

            Set Dic(Str) = Cells(i, ).Resize(, lc) '把当前行装入到字典中

        Else '否则(字典中存在关键字)

            Set Dic(Str) = Union(Dic(Str), Cells(i, ).Resize(, lc)) '把行连合起来

        End If

    Next

    k = Dic.Keys '字典关键字集合

    t = Dic.Items '字典项目集合

    On Error Resume Next

    With Sheets

        For i =  To Dic.Count -  '循环关键字的个数

            Set Sht = .Item(k(i)) '给变量赋值(工作表名为关键字)

            If Sht Is Nothing Then '该工作表不存在则插入一个空工作表

                .Add(After:=.Item(.Count)).Name = k(i) '新建的工作表将置于所有工作表之后，并命名为关键字

                Set Sht = ActiveSheet '活动工作表给变量

            Else '否则

                Sht.Cells.Clear '清除工作中所有内容和格式

            End If

            Rng.Copy Sht.Range("A1") '把标题写入第一行

            t(i).Copy Sht.Range("A2") '写入其他内容

            Sht.Cells.EntireColumn.AutoFit '自动调整全工作表单元格的列宽

            Set Sht = Nothing '变量处于初始状态

        Next

    End With

    Sheets().Activate '第1个工作表处于激活状态

    Application.ScreenUpdating = True '打开屏幕更新

End Sub