如何用数据字典实现多行的值做为item

century_zhang

大家好，
有一个员工信息登记表，想用数据字典，实现员工信息按部门进行分类。但是总是报 类型错误。请各位帮忙看看附件（写了一点VBA 员工信息登记表.rar (12.82 KB, 下载次数: 83)

2015-4-27 00:04 上传

点击文件名下载附件

），怎样实现以部门为key，以满足条件的多行的员工信息做为item储存？ 谢谢大家。

jpj123

提示你考虑用字典嵌套！

chxw68

1. Sub tes()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("register")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a1:e" & r)
   
9.     For i = 2 To UBound(arr)
   
10.       If arr(i, 4) <= #12/31/2013# Then
    
11.         If Not d.exists(arr(i, 1)) Then
    
12.           Set d(arr(i, 1)) = .Cells(i, 1).Resize(1, 5)
    
13.         Else
    
14.           Set d(arr(i, 1)) = Union(d(arr(i, 1)), .Cells(i, 1).Resize(1, 5))
    
15.         End If
    
16.       End If
    
17.     Next
    
18.   End With
    
19.   With Worksheets("sheet2")
    
20.     .UsedRange.Offset(1, 0).Clear
    
21.     For Each aa In d.keys
    
22.       r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
23.       If r = 1 Then r = r + 1 Else r = r + 2
    
24.       d(aa).Copy .Cells(r, 1)
    
25.     Next
    
26.   End With
    
27. End Sub
    

复制代码

chxw68

这个使用单元格区域的union方法就行。

jpj123

字典嵌套也实现了：

1. Public Sub test()
   
2. Dim OBdate, CurRange, k, kk, S, arr, n%
   
3. Set OBdate = CreateObject("Scripting.Dictionary")
   
4. arr = Range("A1:E8")
   
5. Dim CaliRow As Integer, i As Integer, j As Integer
   
6. CaliRow = Worksheets("register").Range("A65535").End(xlUp).Row
   
7. For i = 2 To 8
   
8. If Not OBdate.exists(arr(i, 1)) Then
   
9. Set OBdate(arr(i, 1)) = CreateObject("Scripting.Dictionary")
   
10. End If
    
11.     If arr(i, 4) < DateValue("2013/12/31") Then
    
12.         OBdate(arr(i, 1))(arr(i, 2)) = Range(Cells(i, 1), Cells(i, 5)).Value
    
13.     End If
    
14. Next
    
15. For Each k In OBdate.keys
    
16. CaliRow = Worksheets("register").Range("A65535").End(xlUp).Row
    
17. Cells(CaliRow + 1, 1) = k: n = 0
    
18. For Each kk In OBdate(k).keys
    
19. n = n + 1
    
20.     Cells(CaliRow + 1 + n, 1).Resize(1, 5) = OBdate(k)(kk)
    
21. Next
    
22. Next
    
23. End Sub

复制代码

jpj123

详见附件   

jpj123

chxw68 发表于 2015-4-27 08:23

向老师学习了，原来字典中也可以用UNION 方法！

jpj123

jpj123 发表于 2015-4-27 09:07
向老师学习了，原来字典中也可以用UNION 方法！

不错的口诀，记下了！谢谢老师！！

eric0793

chxw68 发表于 2015-4-27 08:24
这个使用单元格区域的union方法就行。

chxw68老师的代码简洁精炼，逻辑明晰，真是学习的上好材料！

eric0793

eric0793 发表于 2015-4-27 10:46
chxw68老师的代码简洁精炼，逻辑明晰，真是学习的上好材料！

：）老师还要请教下，d(aa).Copy .Cells(r, 1) 是复制格式的，如果需要仅仅输出值该怎么写呢