注册 登录  
 加关注
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

零售创新,创新那些事儿,SPSS,VBA

零售创新

 
 
 

日志

 
 
关于我

新浪微博,零售创新 研究经理,数据分析师 希望和市场研究和零售业的同事共同进步! 本博客发表的都是免费或试用的资料,如果有版权问题请发邮件wangli12a@163.com联系删除。 spss excel vba blog

网易考拉推荐

总表拆分问题  

2012-03-30 13:49:44|  分类: VB和VBA知识 |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |

[已解决]总表拆分问题,请人帮忙。谢谢。

详见附件。
运行代码后想实现效果,产生一个“拆分表”目录及里面的文件,目录里的文件跟附件中“拆分表1”中内容一样。
发现问题:
1、拆分的工作簿中,第四张表“奖罚分”拆不出内容…………
2、拆分到“济南”这个部门时,对象错误。
3、拆分后的工作簿无法保持与总表格式一样。最起码列宽一样。
4、也是最重要的,这才几个部门运行就这么慢。如果部门增加到100个,那是不是计算机会死机?请帮忙优化一下代码!

切盼高手给予帮助,再次表示感谢。

 

 

非常感谢你在
http://club.excelhome.net/viewthread.php?tid=522120
的帮助。
不知能否受累帮忙加上代码注释?学习一下?
再次表示感谢。

以上短信收到,注释如下:
Sub Macro1()
Dim wb As Workbook, arr, sh As Worksheet
Dim k, t, i&, j&, d As Object, ds As Object
Set d = CreateObject("scripting.dictionary") '创建字典对象
Set ds = CreateObject("scripting.dictionary")
For Each sh In Sheets '逐表
Set ds(sh.Name) = CreateObject("scripting.dictionary") '创建该表字典对象
arr = sh.UsedRange '已经使用区域写入数组
For i = 4 To sh.Range("a65536").End(xlUp).Row '逐行
If Len(arr(i, 1)) Then '非空
If Asc(arr(i, 1)) < 0 Then '汉字
d(arr(i, 1)) = "" '部门名称添加到字典键值(不重复部门名称)
ds(sh.Name)(arr(i, 1)) = i '部门名称添加到该表字典键值,行号添加到字典条目
End If
End If
Next
ds(sh.Name)("") = i '多记录一个行号(最后一个非空单元格下面一行)
Next
k = d.Keys '不重复部门名称写入数组
Application.ScreenUpdating = False '关闭屏幕刷新
Application.DisplayAlerts = False '关闭警告
With ThisWorkbook '本工作簿
For i = 0 To UBound(k) '逐个不重复部门
Set wb = Workbooks.Add(xlWBATWorksheet) '新建一个只有一个工作表的工作簿
For Each sh In .Sheets '本工作簿逐表
sh.Copy After:=wb.Sheets(wb.Sheets.Count) '工作表复制到新建工作簿后面
With wb.Sheets(wb.Sheets.Count) '新复制工作表
t = ds(.Name).Items '新复制工作表字典记录所有部门名称行号写入数组
arr = .UsedRange '已经使用区域写入数组
For j = UBound(t) - 1 To 0 Step -1 '从下至上逐个部门名称行号
If arr(t(j), 1) <> k(i) Then .Cells(t(j), 1).Resize(t(j + 1) - t(j)).EntireRow.Delete '如果该部门名称不等于不重复部门则所在区域整行删除
Next
End With
Next
wb.Sheets(1).Delete '删除新建工作簿第一个空工作表
wb.SaveAs ThisWorkbook.Path & "\拆分表1\" & k(i) & ".xls" '另存为新建工作簿,名称为个不重复部门
wb.Close '关闭新建工作簿
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok"
End Sub

  评论这张
 
阅读(420)| 评论(0)
推荐 转载

历史上的今天

在LOFTER的更多文章

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2017