白话Excel函数公式 Office易学宝微视频教程合集(Excel+Word+PPT)
笨办法学VBA(从入门到精通) 高效办公必会的Office实战技巧
财务总监的Excel私房课 Excel数据透视表实战秘技
Excel图表神技
查看: 2748|回复: 4

VBA实战演练系列之2--分级显示处理(优秀解法有适当奖励)

[复制链接]
发表于 2012-3-8 20:32:33 | 显示全部楼层 |阅读模式
这个题也是同学在论坛提的问题:

已建立分级显示的物料,如何将各级的下阶物料(包含第1层级)快速收纳到若干新建工作表中
http://club.excelhome.net/thread-836703-1-1.html






附上自己的解法与附件供参考。优秀解法有适当奖励。呵呵



BOM-hustnzj.rar

76.37 KB, 下载次数: 72

回复

使用道具 举报

发表于 2012-3-8 21:53:35 | 显示全部楼层

Private Sub CommandButton1_Click() t = Timer Application.ScreenUpdating = False

本帖最后由 wmhlwx 于 2012-3-9 10:15 编辑

这个题。。是这样得:A列如果只含有一个点".“就分页。把直到下一个”一个点"之前的拷到新页面。

很简单。 所以代码就不写了。


还是写了 测试时间。 0.9秒。

Private Sub CommandButton1_Click()
t = Timer
Application.ScreenUpdating = False
Sheet1.Outline.ShowLevels RowLevels:=4
r = Range("a60000").End(xlUp).Row
arr = Range("a1:a" & r)
ReDim brr(1 To 200, 1 To 2)  'said to save memeory

For i = 1 To r
If Len(arr(i, 1)) - Len(Replace(arr(i, 1), ".", "")) = 1 Then
k = k + 1
brr(k, 1) = i
brr(k, 2) = arr(i, 1)
End If
Next i

i = 1

Do While brr(i, 1) <> ""
    Sheets.Add after:=Sheets(Sheets.Count)
    With ActiveSheet
    .Name = brr(i, 2)
    Sheet1.Range("A1:K2").Copy .Range("A1")
        If brr(i + 1, 1) <> "" Then
        Sheet1.Range("A" & brr(i, 1) & ":K" & brr(i + 1, 1) - 1).Copy .Range("A3")
        Else
        Sheet1.Range("A" & brr(i, 1) & ":K" & r).Copy .Range("A3")
        End If
    i = i + 1
    End With
Loop
Application.ScreenUpdating = True
MsgBox Timer - t

End Sub

点评

不过还是跟你指出两个不足: 1. 不仔细,原表中有公式;2. 代码的通用性不够(要是没有.怎么办,有点吹毛求疵了哈)  发表于 2012-3-9 17:54
这个代码在我的电脑上要4.5s,我的代码要6s,证明了2件事: 1. 数组比普通单元格操作要快,不过此处优势不大; 2. 你的电脑是极品配置……  发表于 2012-3-9 17:31
想到跟做到是两码事  发表于 2012-3-8 21:56

评分

参与人数 1登攀 +5 收起 理由
hustnzj + 5 不错!

查看全部评分

回复 支持 反对

使用道具 举报

发表于 2012-3-9 10:20:39 | 显示全部楼层
我去。。。还没开课怎么大家都会VBA了。。。泪奔。。。。= =

点评

不用泪奔,大家基础不一样,只要自己有进步就行了  发表于 2012-3-9 17:36
回复 支持 反对

使用道具 举报

 楼主| 发表于 2012-3-9 19:36:27 | 显示全部楼层
本帖最后由 hustnzj 于 2012-3-9 19:37 编辑

还是我来自问自答吧,呵呵。修改1,本机用时2.9s,通用性更强
  1. Private Sub BOM2()                                      '修改1,本机用时2.9s,通用性更强
  2. Dim t As Currency, r%, i%, arr, brr, k%
  3.     t = Timer
  4.     Application.ScreenUpdating = False
  5.     Sheet1.Outline.ShowLevels RowLevels:=4
  6.     r = Range("a60000").End(xlUp).Row
  7.     arr = Range("a1:a" & r)
  8.     ReDim brr(1 To r, 1 To 2)
  9.     For i = 3 To r
  10.         If Rows(i).OutlineLevel = 1 And arr(i, 1) <> "" Then
  11.             k = k + 1
  12.             brr(k, 1) = i
  13.             brr(k, 2) = arr(i, 1)
  14.         End If
  15.     Next i
  16.     i = 1
  17.     Do While brr(i, 1) <> ""
  18.         Sheets.Add after:=Sheets(Sheets.Count)
  19.         With ActiveSheet
  20.             .Name = brr(i, 2)
  21.             If brr(i + 1, 1) <> "" Then
  22.                 Sheet1.Range("A" & brr(i, 1) & ":K" & brr(i + 1, 1) - 1).Copy
  23.                 .[A3].PasteSpecial Paste:=xlPasteValues
  24.             Else
  25.                 Sheet1.Range("A" & brr(i, 1) & ":K" & r).Copy
  26.                 .[A3].PasteSpecial Paste:=xlPasteValues
  27.             End If
  28.             i = i + 1
  29.         End With
  30.     Loop
  31.     Worksheets.FillAcrossSheets (Worksheets("IT004总表").Range("A1:K2"))
  32.     Application.ScreenUpdating = True
  33.     MsgBox Timer - t
  34. End Sub
复制代码

回复 支持 反对

使用道具 举报

发表于 2012-3-9 20:07:24 | 显示全部楼层
本帖最后由 wmhlwx 于 2012-3-9 20:08 编辑
hustnzj 发表于 2012-3-9 19:36
还是我来自问自答吧,呵呵。修改1,本机用时2.9s,通用性更强

1. 原来可以用ROWS.outlinelevel 学习了。
2. pastevalue 比简单的COPY要快。
3. 最后一步. fillacrossheets. 确实省得时间够多。学习了。

电脑是公司的最新的双核电脑 确实还不错。 大型3D软件跑起来都刚刚的。
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 入学

本版积分规则

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