按要求提取组数据的问题

dfshm

附件 按要求提取组数据附件.rar (144.42 KB, 下载次数: 13)

2018-8-6 07:47 上传

点击文件名下载附件

谢谢老师!

xiangbaoan

1. Sub test()
   
2. Dim d, r&, n%, k%
   
3. Application.ScreenUpdating = False
   
4. Set d = CreateObject("scripting.dictionary")
   
5. n = Sheet1.[a1]
   
6. With Sheet2
   
7.     For r = 4 To .Cells(Rows.Count, 1).End(xlUp).Row + 1
   
8.         If .Cells(r, 1) = "" Then
   
9.             If .Range("a" & r - 1).CurrentRegion.Rows.Count = n Then
   
10.                 k = k + 1
    
11.                 If k = 1 Then
    
12.                     Set d(n) = .Range("a" & r - 1).CurrentRegion.Resize(n + 1, 18)
    
13.                 Else
    
14.                     Set d(n) = Union(d(n), .Range("a" & r - 1).CurrentRegion.Resize(n + 1, 18))
    
15.                 End If
    
16.             End If
    
17.         End If
    
18.     Next
    
19. End With
    
20. If k Then
    
21.     With Sheet3
    
22.         .[a:r] = ""
    
23.         d.items()(0).Copy .[a1]
    
24.     End With
    
25. End If
    
26. Set d = Nothing
    
27. Application.ScreenUpdating = True
    
28. MsgBox IIf(k, "ok", "木有!")
    
29. End Sub
    
30. '此为补充，附件中代码考虑欠妥，以此为准

复制代码

………………………………………………

iwangyi

xiangbaoan 发表于 2018-8-6 08:29
………………………………………………

  Set d(n) = Union(d(n), .Range("a" & r - 1).CurrentRegion.Resize(n + 1, 18))老师解释一下

iwangyi

xiangbaoan 发表于 2018-8-6 08:29
………………………………………………

        .[a:r] = ""
        d.items()(0).Copy .[a1]老师，这句也不明白

xiangbaoan

Union(d(n), .Range("a" & r - 1).CurrentRegion.Resize(n + 1, 18))'将多个区域连接在一起装入字典
d.items()(0)'此字典只有一个item ，其索引号是0
'

iwangyi

xiangbaoan 发表于 2018-8-6 09:19
Union(d(n), .Range("a" & r - 1).CurrentRegion.Resize(n + 1, 18))'将多个区域连接在一起装入字典
d.ite ...

谢谢老师，d.items()与d.items()(0)有什么联系。