Split according to contents in a column

2.vb

'将单元格区域插入到一个表的最后
Sub AddRow(sht As Worksheet, rg As Range)
    Dim shtrn As Integer
    Dim rn, cn As Integer
    shtrn = sht.Range("A1").CurrentRegion.Rows.Count
    rn = rg.Rows.Count
    cn = rg.Columns.Count
    rg.Copy sht.Range("A1").Offset(shtrn, 0).Resize(rn, cn)
End Sub

Sub Test_AddRow()
    Dim st As Worksheet
    Dim rg As Range
    Set st = ThisWorkbook.Worksheets("Sheet2")
    Set rg = ThisWorkbook.Worksheets("第二批").Range("A2:N5")
    AddRow st, rg   
End Sub

'按列分拆
'st是将被分拆的工作表，按第c列分拆，newfile是新建工作簿全路径文件名，startrow是被分拆的表的数据开始行（不包括标题行）
Sub split(st As Worksheet, c As Integer, newfile As String, startrow As Integer)
    Dim wb As Workbook
    Dim sht As Worksheet
    Dim rn, cn, i As Integer
    Dim addr As Range

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    '新建工作簿
    If Dir(newfile) <> "" Then
            Kill newfile
    End If
    Set wb = Workbooks.Add
    wb.SaveAs newfile

      '生成工作表
    i = startrow
    Do While st.Cells(i, c).Value <> ""
        On Error Resume Next
        If wb.Worksheets(st.Cells(i, c).Value) Is Nothing Then
            wb.Worksheets.Add after:=wb.Worksheets(wb.Worksheets.Count)
            wb.ActiveSheet.Name = st.Cells(i, c).Value
        End If
        i = i + 1
    Loop

      '删除多余工作表
    wb.Worksheets("Sheet1").Delete
    wb.Worksheets("Sheet2").Delete
    wb.Worksheets("Sheet3").Delete

    '设置表头标题行
    cn = st.Columns.Count
    For Each sht In wb.Worksheets
        st.Range("A2").Offset(startrow - 3, 0).Resize(1, cn).Copy sht.Range("A1").Resize(1, cn)
    Next

    '分拆
    Dim cv As String
    rn = st.Range("A1").CurrentRegion.Rows.Count
    i = startrow
    'addr为当前待分拆行第一个单元格
    Set addr = st.Range("A1").Offset(i - 1, 0)
    cv = addr.Offset(0, c - 1)
    Do While cv <> ""
        AddRow wb.Worksheets(cv), addr.Resize(1, cn)
        i = i + 1
        Set addr = st.Range("A1").Offset(i - 1, 0)
        cv = addr.Offset(0, c - 1)
    Loop   

   '扫尾工作
    wb.Save
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Sub split_test()
    '清单文件夹必须已存在才行
    split ThisWorkbook.Worksheets("第二批"), 14, ThisWorkbook.Path & "\清单\第二批", 2
End Sub

split col.vb

Sub Macro1()
    Dim arr, sh As Worksheet, j&, lr&
    Application.ScreenUpdating = False
    arr = [a1].CurrentRegion
    lr = UBound(arr)
    With Sheets
        For j = 1 To UBound(arr, 2) Step 5
            On Error Resume Next
            Set sh = Sheets(arr(1, j))
            If sh Is Nothing Then
                .Add(After:=.Item(.Count)).Name = arr(1, j)
                Set sh = ActiveSheet
            Else
                sh.Cells.Clear
            End If
            On Error GoTo 0
            .Item(1).Cells(1, j).Resize(lr, 5).Copy sh.[a1]
            Set sh = Nothing
        Next
    End With
    Sheets(1).Activate
    Application.ScreenUpdating = True
End Sub