拆分工作表

brianlong

如图，我想把单号一样的拆出放在新增的工作表
我的思路是先在不同单号间插入空行，在从下往上，取A列最后一个非空单元格到以这个单元格为基点，再取他的往上的最后一个非空单元格
取两个单元格之间的整行剪切，再用循环放到新建工作表里去。但结果却不尽人意。
大侠帮我指正一下哪里的问题，或者帮我提出一些更简洁的方法。谢谢

不知道为什么

论坛拆分的教程很多，楼主可以学习下，你的方法有点太绕了啊。用字典和数组应该会比较容易理解

不知道为什么

朱荣兴 发表于 2018-7-12 23:31
到我的主题里去下载    灵活拆分工具

供参考

拆.zip (17.17 KB, 下载次数: 52)

2018-7-12 23:46 上传

点击文件名下载附件

刚发现@错朱老师了，抱歉，请老师忽略！

jy03342543

在微信教学上"看见星光"写的自定义拆分工作表代码希望能帮到你
Sub 自定义拆分工作表()
Dim d As Object, Sht As Worksheet, arr, brr, r, kr, I&, J&, k&, X&
Dim Rng As Range, Rg As Range, tRow&, tCol&, aCol&, pd&, Cll As Range
Dim Mystr$
Set d = CreateObject("scripting.dictionary") '建立后期字典绑定
Set Rg = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8)
    '选择的拆分依据列
    tCol = Rg.Column '取拆分依据列列标
    tRow = Val(Application.InputBox("请输入总表标题行的行数？"))
    '设置总表的标题行数
    If tRow < 0 Then MsgBox "标题行数不能为负数，程序退出。": Exit Sub
    Set Rng = ActiveSheet.UsedRange '总表的数据区域
    Set Cll = ActiveSheet.Cells '总表的单元格集
    arr = Rng '数据范围装入数组arr
    tCol = tCol - Rng.Column + 1 '计算依据列在数组中的位置
    aCol = UBound(arr, 2) '数据源的列数
    For I = tRow + 1 To UBound(arr) '遍历数组arr
        If arr(I, tCol) = "" Then arr(I, tCol) = "单元格空白"
        Mystr = arr(I, tCol) '统一转换为字符串格式
        If Not d.exists(Mystr) Then
            d(Mystr) = I '字典中不存在关键词则将行号装入字典
        Else
            d(Mystr) = d(Mystr) & "," & I '如果存在则合并行号，以逗号间隔
        End If
    Next
    Application.DisplayAlerts = False '关闭警告信息提示
    For Each Sht In ActiveWorkbook.Worksheets '遍历一遍工作表，如果字典中存在则删除
   If d.exists(Sht.Name) Then Sht.Delete
    Next
    Application.DisplayAlerts = True '恢复警告信息
    kr = d.keys '字典的key集
    Application.ScreenUpdating = False '关闭屏幕刷新
    For I = 0 To UBound(kr) '遍历字典key值
     If kr(I) <> "" Then '如果key不为空
       r = Split(d(kr(I)), ",") '取出item里储存的行号
         ReDim brr(1 To UBound(r) + 1, 1 To aCol) '声明放置结果的数组brr
          k = 0
            For X = 0 To UBound(r)
              k = k + 1 '累加记录行数
                 For J = 1 To aCol '读取遍历列
                    brr(k, J) = arr(r(X), J)
              Next
            Next
          With Worksheets.Add(, Sheets(Sheets.Count - 3)) '新建一个工作表，位置在所有已存在sheet的后面
            .Name = kr(I) '表格命名
              .[a1].Resize(UBound(arr), aCol).NumberFormat = "@" '设置文本格式
                If tRow > 0 Then .[a1].Resize(tRow, aCol) = arr '放标题行
                  .[a1].Offset(tRow, 0).Resize(k, aCol) = brr '放置数据区域
                    Cll.Copy '复制粘贴总表的格式
                 .[a1].PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
               .[a1].Select
            End With
        End If
    Next
  Rng.Parent.Activate '激活总表
Application.ScreenUpdating = True '恢复屏幕更新
Set d = Nothing '释放字典
Erase arr: Erase brr '释放数组
MsgBox "数据拆分完成！"
End Sub

brianlong

jy03342543 发表于 2018-7-13 11:40
在微信教学上"看见星光"写的自定义拆分工作表代码希望能帮到你
Sub 自定义拆分工作表()
Dim d As Object, ...

好的，我看看，感谢