[已解决]历遍工作表提取数据的问题

晓敏

附件 历遍工作表提取数据附件.rar (108.58 KB, 下载次数: 14)

2016-3-31 19:27 上传

点击文件名下载附件
谢谢！

最佳答案

月排行榜 / 总排行榜

高

2016-4-1 10:50

y加了1，问题解决了。

跳转到最佳答案楼层

高

附件

晓敏

高 发表于 2016-3-31 23:38
附件

老师你好，谢谢帮助．试了一下，运行正常，仔细查看了一下，有个小问题．

即，当一个工作表中，最后一个大组超过四组或超过五组时，数据无法提取．
比如，你做好的附件中，Sheet10里，五组的共有两个，查询显示的结果却是一个．经仔细试运行，原来，表１０里，这没有显示的一组，位置居最后；

经过进一步试运行，发现，凡是位置在各工作表最后一组的，符合条件的数据，都不能提取出来．

dsmch

1. Sub Macro1()
   
2. Dim arr, d, j%, i&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Sheets(1).Activate
   
5. [a:j] = "": n = 1: sl = [l1]
   
6. For j = 2 To Sheets.Count
   
7.     With Sheets(j)
   
8.         arr = .Range("a1:i" & .Range("a65536").End(xlUp).Row + 3)
   
9.         p = 1
   
10.         For i = 2 To UBound(arr) - 1
    
11.             If arr(i, 1) = "" And (arr(i + 1, 1) <> "" Or i = UBound(arr) - 1) Then p = p & "," & i
    
12.             If arr(i, 1) = "" And arr(i - 1, 1) = "" Then
    
13.                 s = s + 1
    
14.                 d(s) = p: p = i + 1
    
15.             End If
    
16.         Next
    
17.         For Each m In d.items
    
18.             x = Split(m, ",")
    
19.             If UBound(x) >= sl Then
    
20.                 For i = UBound(x) - 4 + 1 To UBound(x)
    
21.                     .Range(.Cells(x(i - 1), 1), .Cells(x(i), "I")).Copy Cells(n, 1)
    
22.                     n = Range("a65536").End(xlUp).Row + 1
    
23.                 Next
    
24.                 Cells(n - 1, "j") = .Name
    
25.                 n = n + 2
    
26.             End If
    
27.         Next
    
28.     End With
    
29.     d.RemoveAll
    
30. Next
    
31. End Sub

复制代码

高

y加了1，问题解决了。