ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: 朱荣兴

[分享] 灵活拆分工具

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2018-8-28 12:03 | 显示全部楼层
牛掰,牛掰,谢谢

TA的精华主题

TA的得分主题

发表于 2018-9-2 18:03 | 显示全部楼层
太好了,谢谢楼主分享。有时需要汇总求和,有办法吗?
头像被屏蔽

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-9-2 18:16 来自手机 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
提示: 作者被禁止或删除 内容自动屏蔽

TA的精华主题

TA的得分主题

发表于 2018-9-3 20:29 | 显示全部楼层
lsc900707 发表于 2016-12-13 17:56
感谢朱老师分享这么好的工具。先帮顶。

太死板了 如果是多列条件怎么办???

TA的精华主题

TA的得分主题

发表于 2018-9-3 20:31 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2018-9-3 20:33 | 显示全部楼层
随意多条件工作表拆分工具
  1. Sub 工作表拆分()
  2.     Application.ScreenUpdating = False
  3.     Application.DisplayAlerts = False
  4.     Dim arr As Variant
  5.     Dim i, s As Integer
  6.     Dim brr()
  7.     Dim wb, wb1 As Workbook
  8.     Dim d As Object
  9.     Dim hlrow As Integer, cutcolumn As Integer, cuttype As Integer
  10.     Set d = CreateObject("scripting.dictionary")
  11.     Dim sh As Worksheet
  12.     hlrow = InputBox("请输入标题最末行数:", "拆分表格", "1")
  13.     bwhs = InputBox("请输入表尾的总行数:", "拆分表格", "0")
  14.     cutcolumn = InputBox("请输入拆分依据列(第一列是1,第二列是2,以此类推):", "拆分表格", "1")
  15.     cuttype = InputBox("请选择拆分类型(拆分到本工作簿是1,拆分为多个独立工作簿是2,拆分为一个工作簿是3):", "拆分表格", "1")
  16.     bb = MsgBox("是否去除表尾 是为去除 否为保留表尾", vbYesNo)

  17.     lastCol = Selection.SpecialCells(xlCellTypeLastCell).Column
  18.     lastRow = Selection.SpecialCells(xlCellTypeLastCell).Row
  19.     arr = ActiveSheet.Range("a1", ActiveSheet.Cells(lastRow - bwhs, lastCol))
  20.     For i = hlrow + 1 To UBound(arr)
  21.         If Not d.exists(arr(i, cutcolumn)) Then
  22.           If Cells(i, cutcolumn) = "" Then GoTo 3
  23.             Set d(arr(i, cutcolumn)) = ActiveSheet.Range("a" & i).Resize(1, UBound(arr, 2))
  24.         Else
  25.             Set d(arr(i, cutcolumn)) = Union(d(arr(i, cutcolumn)), ActiveSheet.Range("a" & i).Resize(1, UBound(arr, 2)))

  26.         End If
  27. 3:
  28.     Next i
  29.    x = d.keys
  30. If cuttype = 1 Then

  31. For k = 0 To d.Count - 1
  32.          
  33.          
  34.             Worksheets.Add after:=Worksheets(Worksheets.Count)
  35.          
  36.             ActiveSheet.Name = x(k)
  37.             ThisWorkbook.Worksheets(1).Rows("1:" & hlrow).Copy ActiveSheet.[a1]
  38.             d.items()(k).Copy ActiveSheet.Cells(hlrow + 1, 1)
  39.             If bb = 7 Then
  40.             zdRow = Selection.SpecialCells(xlCellTypeLastCell).Row
  41.             qsh = lastRow - Val(bwhs) + 1
  42.             ThisWorkbook.Worksheets(1).Rows(qsh & ":" & lastRow + 1).Copy ActiveSheet.Cells(zdRow + 1, 1)
  43.             Else
  44.            End If
  45. Next k
  46. End If
  47.   If cuttype = 3 Then
  48.         Application.SheetsInNewWorkbook = d.Count
  49.         Set wb1 = Workbooks.Add
  50.         i = 1
  51.         For Each k In d.keys
  52.             wb1.Worksheets(i).Name = k
  53.            wb1.Worksheets(i).Activate
  54.              ThisWorkbook.Worksheets(1).Rows("1:" & hlrow).Copy wb1.Worksheets(x(k1)).[a1]
  55.             d.items()(k1).Copy wb1.Worksheets(x(k1)).Cells(hlrow + 1, 1)
  56.             If bb = 7 Then
  57.             zdRow = Selection.SpecialCells(xlCellTypeLastCell).Row
  58.             qsh = lastRow - Val(bwhs) + 1
  59.             ThisWorkbook.Worksheets(1).Rows(qsh & ":" & lastRow + 1).Copy ActiveSheet.Cells(zdRow + 1, 1)
  60.             Else
  61.             End If
  62.             k1 = k1 + 1
  63.             i = i + 1
  64.         Next k
  65.     End If
  66.    
  67.     For k = 0 To UBound(x)
  68.       
  69.         If cuttype = 2 Then
  70.             Application.SheetsInNewWorkbook = 1
  71.             Set wb = Workbooks.Add
  72.             With wb.Worksheets(1)
  73.                 ThisWorkbook.Worksheets(1).Rows("1:" & hlrow).Copy .[a1]
  74.                 d.items()(k).Copy .Cells(hlrow + 1, 1)
  75.                  If bb = 7 Then
  76.             zdRow = Selection.SpecialCells(xlCellTypeLastCell).Row
  77.             qsh = lastRow - Val(bwhs) + 1
  78.             ThisWorkbook.Worksheets(1).Rows(qsh & ":" & lastRow + 1).Copy ActiveSheet.Cells(zdRow + 1, 1)
  79.             Else
  80.             End If
  81.                 wb.SaveAs Filename:=ThisWorkbook.Path & "" & x(k) & ".xls"
  82.                 wb.Close
  83.             End With
  84.         End If
  85.     Next k
  86.     If cuttype = 3 Then
  87.         wb1.SaveAs Filename:=ThisWorkbook.Path & "" & "拆分数据表.xls"
  88.         wb1.Close False
  89.     End If
  90. 5:
  91.     Application.DisplayAlerts = True
  92.     Application.ScreenUpdating = True
  93.     MsgBox "拆分完毕!"
  94.    
  95. End Sub
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-9-3 20:33 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
不知你们都是怎么看的

TA的精华主题

TA的得分主题

发表于 2018-9-3 20:34 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2018-9-3 20:35 | 显示全部楼层
什么才叫工具   不能应用于实际工作的叫工具吗???

TA的精华主题

TA的得分主题

发表于 2018-9-3 20:38 | 显示全部楼层
我发的可以不管你好多条件 只要不超过字段名的都可以作为拆分工作表条件 一个也可以 就只需你动动鼠或者输入数字就行了
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-6-16 03:21 , Processed in 1.057175 second(s), 17 queries , Gzip On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表