Excel工作表按列拆分成表内工作表代码修改

szqhb

收集一代码，可以把指定工作表（即总表）按列拆分成独立的工作表。但在本附件按班级拆分时就有点问题，某行(有时453行、有时1900行)数据会重复出现在各班分表的行末或者第二行。不知道如何修改重新写代码，使得拆分后的数据准确（要保留人工选择拆分列数和表头行数）

见附件内代码

晨检学生数据201612晨检好.rar (86.03 KB, 下载次数: 45)

2017-1-4 17:47 上传

点击文件名下载附件

szqhb

朱荣兴 发表于 2017-1-4 18:54
原来的代码运行效率太低，可以改成这样

十分感谢！2楼那个链接好，可拆分为表内、表外的。3楼代码拆分后原表格线没有了

szqhb

又得一代码，可惜只能拆分表头只有一行的，多行的不知在哪修改代码
Sub hjs()
Dim irow&, i&
Dim H As New Collection
Dim sht As Worksheet
Dim A
Dim ICol

Set A = ActiveCell
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sht In Sheets
    If sht.Name <> "总表" Then sht.Delete              '删除所有分表
Next
Application.DisplayAlerts = True

ICol = Application.InputBox("请输入你所要分的列：（如按B列分请输入2）", "提示：", "2", Type:=1)
If ICol = "" Then Exit Sub

On Error Resume Next
    With Sheets("总表")
        irow = .[a1].CurrentRegion.Rows.Count
        For i = 2 To irow '从第2行开始取数
           H.Add .Cells(i, ICol), CStr(.Cells(i, ICol))
        Next                                            '建立一个不重复的筛选条件

  For i = 1 To H.Count
    .Cells.AutoFilter field:=ICol, Criteria1:=H(i)
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = H(i)
    .[a1].CurrentRegion.Copy Sheets(CStr(H(i))).[a1]     '自动筛选，并复制到新建的表中
    .Cells.AutoFilter
    Debug.Print H(i)
  Next
    End With
Application.ScreenUpdating = True

    A.Parent.Activate
    A.Activate                                           '激活汇总表的原来激活的单元格
End Sub

0912199

szqhb 发表于 2017-1-5 11:23
又得一代码，可惜只能拆分表头只有一行的，多行的不知在哪修改代码
Sub hjs()
Dim irow&, i&

厉害了楼主，这个代码看起来很复杂，用起来非常简单实用