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

hustnzj

这个题也是同学在论坛提的问题：

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






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

wmhlwx

这个题。。是这样得：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

Carrie-Wang

我去。。。还没开课怎么大家都会VBA了。。。泪奔。。。。= =

hustnzj

还是我来自问自答吧，呵呵。修改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
    

复制代码

wmhlwx

hustnzj 发表于 2012-3-9 19:36
还是我来自问自答吧，呵呵。修改1，本机用时2.9s，通用性更强

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

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