【字典201201班】A组（A01—A22）第2讲作业上交贴

周义坤

1. Sub ek_sky()
   
2. Dim arr, arr1, arr2, arr3
   
3. Dim i&, j&, l&, m&
   
4. Dim k As New Dictionary
   
5. Application.ScreenUpdating = False
   
6. arr = Range("A2:d" & Cells(Rows.Count, 1).End(3).Row)
   
7. arr1 = Range("E2:F6")
   
8. For i = 1 To UBound(arr1)
   
9. For j = 1 To UBound(arr)
   
10. If arr1(i, 1) = arr(j, 2) Then
    
11. arr(j, 4) = arr1(i, 2)
    
12. End If
    
13. Next j
    
14. Next i
    
15. ReDim Preserve arr(1 To UBound(arr), 1 To 4)
    
16. For l = 1 To UBound(arr)
    
17. k(Format(arr(l, 1), "m月") & "|" & arr(l, 2)) = k(Format(arr(l, 1), "m月") & "|" & arr(l, 2)) + arr(l, 3) * arr(l, 4)
    
18. Next l
    
19. arr2 = k.Keys
    
20. ReDim arr3(1 To k.Count, 1 To 2)
    
21. For m = 0 To UBound(arr2)
    
22. arr3(m + 1, 1) = Split(arr2(m), "|")(0)
    
23. arr3(m + 1, 2) = Split(arr2(m), "|")(1)
    
24. Next m
    
25. Application.ScreenUpdating = True
    
26. Range("H2:J10000").ClearContents
    
27. Range("H2").Resize(k.Count, 2) = arr3
    
28. Range("J2").Resize(k.Count, 1) = Application.Transpose(k.Items)
    
29. End Sub
    

复制代码

无聊的疯子

A22:无聊的疯子

作业:
第2讲-A22-无聊的疯子.zip (98.94 KB, 下载次数: 14)

2012-6-10 15:47 上传

点击文件名下载附件

xyf2210

1. Option Explicit
   
2. Sub aa()    '作业代码写在该模块
   
3.     Dim d As New Dictionary, d1 As New Dictionary, arr, i, j
   
4.     arr = Range("e1").CurrentRegion
   
5.     For i = 2 To UBound(arr)
   
6.         d1(arr(i, 1)) = arr(i, 2)
   
7.     Next
   
8.     arr = Range("a1").CurrentRegion
   
9.     For i = 2 To UBound(arr)
   
10.         d(Month(arr(i, 1)) & "月" & "|" & arr(i, 2)) = d1(arr(i, 2)) * arr(i, 3) + d(Month(arr(i, 1)) & "月" & "|" & arr(i, 2))
    
11.     Next
    
12.     ReDim arr(0 To d.Count - j, 1 To 3)
    
13.     For i = 0 To d.Count - 1
    
14.         arr(i, 1) = Split(d.Keys(i), "|")(0)
    
15.         arr(i, 2) = Split(d.Keys(i), "|")(1)
    
16.         arr(i, 3) = d.Items(i)
    
17.     Next
    
18.     Range("h2").Resize(d.Count, 3) = arr
    
19.     Set d = Nothing: Set d1 = Nothing
    
20. End Sub

复制代码

w2001pf

第2讲-A13-w2001pf
sub aa()    '作业代码写在该模块
Dim d As New Dictionary
    Dim i As Long, x As Long, t As Long
    Dim arr
    Dim arr2
    arr2 = Range("e2:f6")
    For i = 2 To 111
        d(Month(Cells(i, 1)) & "月" & "|" & Cells(i, 2)) = d(Month(Cells(i, 1)) & "月" & "|" & Cells(i, 2)) + Cells(i, 3)
    Next i
    ReDim arr(d.Count - 1, 1 To 3)
    For x = 0 To d.Count - 1
        arr(x, 1) = Split(d.Keys(x), "|")(0)
        arr(x, 2) = Split(d.Keys(x), "|")(1)
            For t = 1 To 5
                If arr(x, 2) = arr2(t, 1) Then
                    arr(x, 3) = d.Items(x) * arr2(t, 2)
                End If
            Next t
    Next x
    Range("h2").Resize(d.Count, 3) = arr
End Sub

xdwy81129

第2讲-A01-xdwy81129.rar (32.14 KB, 下载次数: 1)

2012-6-10 22:53 上传

点击文件名下载附件

Sub aa()    '作业代码写在该模块
Dim arr, i&, n&
Dim zd1, zd2, je#
arr = Range("A1").Resize(Cells(1, 1).End(4).Row, 6)
Set zd1 = CreateObject("scripting.dictionary")
Set zd2 = CreateObject("scripting.dictionary")
For i = 2 To Cells(1, 5).End(4).Row
zd2(arr(i, 5)) = zd2(arr(i, 5)) + arr(i, 6)
Next i
For i = 2 To UBound(arr)
je = zd2(arr(i, 2))
zd1(Month(arr(i, 1)) & "月 " & arr(i, 2)) = zd1(Month(arr(i, 1)) & "月 " & arr(i, 2)) + arr(i, 3) * je
Next i
Columns("H:N").Clear 'Contents
[H1] = "月份"
[I1] = "品种"
[J1] = "金额 "
[H2].Resize(zd1.Count, 1) = Application.Transpose(zd1.Keys)
[H2].Resize(zd1.Count, 1).TextToColumns Destination:=Range("H2"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
[J2].Resize(zd1.Count, 1) = Application.Transpose(zd1.Items)
[J2].Resize(zd1.Count, 1).NumberFormatLocal = "#,##0.00_ "
End Sub


有附件有代码，谢谢学委批改

zhongnansha2011

第二讲-A19-zhongnansha2011.rar (32.04 KB, 下载次数: 6)

2012-6-11 18:59 上传

点击文件名下载附件

思密达0

谢谢吴姐。

心灯芯

Sub aa()    '作业代码写在该模块
    Dim d As New Dictionary
    Dim d2 As New Dictionary
    Dim arr, arr2, i As Integer
    arr = Range("a2:c111")
    Range("h2:J111") = ""
    For i = 2 To 6
        d.Add Cells(i, "E").Value, Cells(i, "f")
    Next
    For i = 1 To UBound(arr)
        d2(Month(arr(i, 1)) & "｜" & arr(i, 2)) = d2(Month(arr(i, 1)) & "｜" & arr(i, 2)) + arr(i, 3) * d(arr(i, 2))
    Next
    ReDim arr2(d2.Count - 1, 1 To 3)
    For i = 0 To d2.Count - 1
        arr2(i, 1) = Split(d2.Keys(i), "｜")(0) & "月"
        arr2(i, 2) = Split(d2.Keys(i), "｜")(1)
        arr2(i, 3) = d2.Items(i)
    Next
    Range("h2").Resize(d2.Count - 1, 3) = arr2
End Sub

liuguansky

参考代码：[前期绑定]
Sub aa()   
    Dim D As New Dictionary, Ar1, Ar2, Syf$, Ske$
    Dim Arr(1 To 60000, 1 To 3), i&, K&
    Ar1 = [a1].CurrentRegion.Value
    Ar2 = [e1].CurrentRegion.Value
    For i = 2 To UBound(Ar2)
      D.Add Ar2(i, 1), Ar2(i, 2)
    Next i
    For i = 2 To UBound(Ar1)
        Syf = Format(Ar1(i, 1), "mÔÂ")
        Ske = Syf & Ar1(i, 2)
        If D.Exists(Ar1(i, 2)) Then
            If D.Exists(Ske) Then
                Arr(D(Ske), 3) = Arr(D(Ske), 3) + Ar1(i, 3) * D(Ar1(i, 2))
            Else
                K = K + 1: D.Add Ske, K
                Arr(K, 1) = Syf: Arr(K, 2) = Ar1(i, 2): Arr(K, 3) = Ar1(i, 3) * D(Ar1(i, 2))
            End If
        End If
    Next i
    Range("h2:j" & Rows.Count).ClearContents
    [h2].Resize(K, 3) = Arr
    set  d=nothing
End Sub

作业中的问题：
1.引用工作表函数；
2.单元格操作；
3.含计算或引用对象的表达式，没有养成赋值给变量的习惯；
4.关于D.KEYS/ITEMS方法生成的数组，前期绑定可直接引用数组中的元素，后期绑定不可直接引用；如果要引用KEYS/ITEMS方法生成的数组中的元素，建议是用变量赋值后，再引用；[不要怕定义变量]
5.代码缩进；
6.赋值前清空结果区域；
7.获取ITEM时，尽量判断KEY是否存在；[若有新建需要，可采用简写方式]；
8.返回D.KEYS/ITEMS方法时，建议是判断D.COUNT>0，再进行后续的处理；
9.字典使用完，释放内存。