ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 Excel转在线管理系统,怎么做看这里 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 EH云课堂直播课程免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 909|回复: 4

如何将总表拆分成多个分表

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-2-11 18:38 | 显示全部楼层 |阅读模式
怎么将数据源拆分成以部门为单位的多个分表

数据源.rar

8.95 KB, 下载次数: 11

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-2-11 18:40 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-2-11 20:43 来自手机 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-2-12 10:18 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-2-13 17:35 | 显示全部楼层
本帖最后由 左面的鱼 于 2019-2-13 17:36 编辑

按列拆分是不用VBA就能实现吗?想知道。
这个问题网上搜搜就能找到代码。
下面代码就是按A列拆分,从网上找的。

  1. Sub Sepsheets()
  2. ' Sepsheets Macro
  3. ' 将工作薄的内容按A列分类从第二行开始放入不同工作薄中。
  4. Dim i As Integer
  5. Dim j As Integer
  6. ' i & j 用于行循环
  7. Dim k As Integer
  8. Dim h As Integer
  9. ' k & h用于excel表单循环
  10. Dim m As Integer
  11. 'm用于根据表头内容判断有多少列需要分页
  12. Dim n As Integer
  13. '临时变量,用于判断是否需要新建表单
  14. Dim p As String
  15. 'p 代表当前工作表单表单名
  16. Dim q As String
  17. 'q用于表示以A列中分类的内容为名建立的表单
  18. Range("a1").Select
  19. p = ActiveSheet.Name
  20. j = ActiveSheet.[a65536].End(3).Row
  21. m = Sheets(p).Cells(1, 256).End(xlToLeft).Column
  22. h = Sheets.Count
  23. n = 0
  24. For i = 2 To j
  25.     Sheets(p).Select
  26.     If Range("A" & i).Value <> "" Then
  27.    
  28.         For k = 1 To h
  29.             If Sheets(k).Name <> Range("A" & i).Value Then
  30.                 n = n + 1
  31.             End If
  32.         Next k
  33.         If n = h Then
  34.             Sheets.Add after:=Sheets(h)
  35.             h = h + 1
  36.             Sheets(h).Name = Sheets(p).Range("A" & i).Value
  37.             Sheets(p).Range("A1:" & Chr(m + 64) & "1").Copy Sheets(h).Range("a1")
  38.         End If
  39.         n = 0
  40.         q = Sheets(p).Range("A" & i).Value
  41.         Sheets(p).Range("A" & i & ":" & Chr(m + 64) & i).Copy Sheets(q).[a65536].End(3).Offset(1, 0)
  42.     End If
  43. Next i
  44. End Sub
复制代码
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

关注官方微信,高效办公专列,每天发车

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

GMT+8, 2019-10-14 18:21 , Processed in 0.053199 second(s), 12 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

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

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

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