按E列和V列自动拆分怎么样设置

安全网

Sub test()
    Call 按总表K列数据分列存到各新表
    Call 工作表另存为工作薄
    Call 分列各子表
End Sub
Sub 工作表另存为工作薄() '将同一工作薄的工作表分别另存为工作薄
    Dim i As Integer, wb As Workbook, mypath As String
    Set wb = ActiveWorkbook
    For i = 1 To wb.Sheets.Count
    wb.Sheets(i).Copy
    mypath = ThisWorkbook.Path & "\" & wb.Sheets(i).Name & ".xls"
    ActiveWorkbook.SaveAs mypath    '活动工作薄另存为
    ActiveWindow.Close            '关闭窗口
    Next
End Sub
Sub 按总表K列数据分列存到各新表()
    On Error Resume Next    '忽略错误继续执行
    Dim mysh As Worksheet, myfz As Worksheet '定义mysh为总工作表,myfz 为复制后工作表
    Dim mynr As String '定义mynr为字符型，获取表格内容
    Dim i As Integer, z As Integer, lastrow As Integer, fzlastrow As Integer, myshcolumn As Integer
    Set mysh = Sheets(1) '把总表赋值给mysh
    lastrow = mysh.Cells(Rows.Count, 1).End(xlUp).Row '取得mysh表的最大行数
    For i = 3 To lastrow '从第3行开始循环到最后一行，行数
        mynr = mysh.Cells(i, "K") '获取mysh表内j列的内容给mynr
    Set myfz = Worksheets(mynr) '把以mynr工作表命名的工作表赋值给myfz
    If Err.Number = 9 Then '如果下标越界
         Worksheets.Add(after:=Worksheets(Worksheets.Count), Count:=1, Type:=xlWorksheet) _
         .Name = mynr '新增工作表在最后一个，取名为mynr
        Set myfz = Worksheets(mynr)
        mysh.Range("A1:l2").Copy myfz.Range("A1")    'mysh的表A1:E2表头复制到myfz工作表表头区域
        Err.Clear
    End If
    fzlastrow = myfz.Cells(Rows.Count, 1).End(xlUp).Row     '取得myfz表的最后非空行
    myshcolumn = Application.WorksheetFunction.CountA(mysh.Rows(2)) '获得mysh表数据列数
    For z = 1 To myshcolumn                                    '循环列数
        myfz.Cells(fzlastrow + 1, z) = mysh.Cells(i, z)         '将原总表数据赋值给复制后的工作表myfz
        myfz.Cells(fzlastrow + 1, z).Borders.LineStyle = xlContinuous '设置数据线条格式
    Next
    Next
    mysh.Activate
End Sub
Sub 分列各子表()
    Dim f As String, mypath As String
    Dim wb As Workbook, sh As Worksheet
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    f = Dir(ThisWorkbook.Path & "\*.xls*")
    Do
        If f <> "拆分工作簿.xls" Then
        mypath = ThisWorkbook.Path & "\" & f
        Workbooks.Open mypath
        Call 按总表e列数据分列存到各新表
        ActiveWorkbook.Close True
        End If
        f = Dir
    Loop Until f = ""
    Kill ThisWorkbook.Path & "\" & Sheets(1).Name & ".xls*"
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
Sub 按总表e列数据分列存到各新表()
    On Error Resume Next    '忽略错误继续执行
    Dim mysh As Worksheet, myfz As Worksheet '定义mysh为总工作表,myfz 为复制后工作表
    Dim mynr As String '定义mynr为字符型，获取表格内容
    Dim i As Integer, z As Integer, lastrow As Integer, fzlastrow As Integer, myshcolumn As Integer
    Set mysh = Sheets(1) '把总表赋值给mysh
    lastrow = mysh.Cells(Rows.Count, 1).End(xlUp).Row '取得mysh表的最大行数
    For i = 3 To lastrow '从第3行开始循环到最后一行，行数
        mynr = mysh.Cells(i, "e") '获取mysh表内i列的内容给mynr
    Set myfz = Worksheets(mynr) '把以mynr工作表命名的工作表赋值给myfz
    If Err.Number = 9 Then '如果下标越界
         Worksheets.Add(after:=Worksheets(Worksheets.Count), Count:=1, Type:=xlWorksheet) _
         .Name = mynr '新增工作表在最后一个，取名为mynr
        Set myfz = Worksheets(mynr)
        mysh.Range("A1:l2").Copy myfz.Range("A1")    'mysh的表A1:E2表头复制到myfz工作表表头区域
        Err.Clear
    End If
    fzlastrow = myfz.Cells(Rows.Count, 1).End(xlUp).Row     '取得myfz表的最后非空行
    myshcolumn = Application.WorksheetFunction.CountA(mysh.Rows(2)) '获得mysh表数据列数
    For z = 1 To myshcolumn                                    '循环列数
        myfz.Cells(fzlastrow + 1, z) = mysh.Cells(i, z)         '将原总表数据赋值给复制后的工作表myfz
        myfz.Cells(fzlastrow + 1, z).Borders.LineStyle = xlContinuous '设置数据线条格式
    Next
    Next
    mysh.Activate
End Sub
还要复制工作表的第一二行标题栏