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

wcymiss

注意：
      1：作业尽量通过自己思考独立完成，不会的可在同学之间私聊讨论，禁止在QQ群公开讨论。
       2：本帖已经设置仅作者可见，作业可以以压缩附件形式或者直接贴代码提交。（压缩文件名格式：第1讲-A01-论坛ID）
       3：非本组学员作业不得交于此处，不得为抢沙发而占位，不得跟灌水帖，违者扣分。
       4：上交作业截止时间：2012年6月12日18：00。
       5：补交作业截止时间：2012年6月13日18：00。（只记考勤，不做批改）

tt253605057

第2讲-A04-tt25360505 上交作业

1. Sub aa()    '作业代码写在该模块
   
2. 
   
3.     Dim d1 As Object, d2 As Object, arr, brr, i%, j%, crr(), t, K, L%
   
4.     Set d1 = CreateObject("SCRIPTING.DICTIONARY")
   
5.     arr = [E2：F6]
   
6.     For i = 1 To UBound(arr)
   
7.         d1(arr(i, 1)) = arr(i, 2)
   
8.     Next i
   
9.     Set d2 = CreateObject("SCRIPTING.DICTIONARY")
   
10.     brr = Range("A2", [C65536].End(3))
    
11.     For j = 1 To UBound(brr)
    
12.         d2(Month(brr(j, 1)) & "月," & brr(j, 2)) = d2(Month(brr(j, 1)) & "月," & brr(j, 2)) + brr(j, 3) * d1(brr(j, 2))
    
13.     Next j
    
14.     t = d2.Keys: K = d2.Items
    
15.     ReDim crr(0 To d2.Count - 1, 1 To 3)
    
16.     For L = 0 To UBound(t)
    
17.         crr(L, 1) = Split(t(L), ",")(0)
    
18.         crr(L, 2) = Split(t(L), ",")(1)
    
19.         crr(L, 3) = K(L)
    
20.     Next L
    
21.     Range("H2").Resize(UBound(t) + 1, 3) = crr
    
22.     Set d1 = Nothing: Set d2 = Nothing
    
23. End Sub
    

复制代码

byhdch

1. Sub aa()
   
2.     Dim d As New Dictionary
   
3.     Dim i, j, k, x, y As Long
   
4.     Dim arr1, arr2, arr3(1 To 1000, 1 To 1), arr4, arr5
   
5.     arr1 = Range("B2:C" & Range("C65536").End(xlUp).Row)
   
6.     arr2 = Range("E2:F" & Range("F65536").End(xlUp).Row)
   
7.     For i = 1 To UBound(arr1)
   
8.         For j = 1 To UBound(arr2)
   
9.             If arr1(i, 1) = arr2(j, 1) Then
   
10.                 k = k + 1
    
11.                 arr3(k, 1) = arr1(i, 2) * arr2(j, 2)
    
12.             End If
    
13.         Next j
    
14.     Next i
    
15.     arr4 = Range("A2:C" & Range("A65536").End(xlUp).Row)
    
16.     For x = 1 To UBound(arr4)
    
17.         d(VBA.Month(arr4(x, 1)) & "月" & "|" & arr4(x, 2)) = d(VBA.Month(arr4(x, 1)) & "月" & "|" & arr4(x, 2)) + arr3(x, 1)
    
18.     Next x
    
19.     ReDim arr5(d.Count - 1, 1 To 3)
    
20.     For y = 0 To d.Count - 1
    
21.         arr5(y, 1) = Split(d.Keys(y), "|")(0)
    
22.         arr5(y, 2) = Split(d.Keys(y), "|")(1)
    
23.         arr5(y, 3) = d.Items(y)
    
24.     Next y
    
25.     Range("H2:J50").ClearContents
    
26.     Range("H2").Resize(d.Count, 3) = arr5
    
27. End Sub

复制代码

第2讲-A20-byhdch.rar (32.04 KB, 下载次数: 6)

2012-6-8 23:23 上传

点击文件名下载附件

sliang28

1. Sub aa()    '作业代码写在该模块
   
2. Dim i, j, k As Long
   
3. Dim mon As Integer
   
4. Dim d1 As New Dictionary
   
5. Dim d2 As New Dictionary
   
6. Dim arr As Variant
   
7. Dim list(1 To 60, 1 To 3) As Variant
   
8. arr = [A2:C111]
   
9. k = 1
   
10. 
    
11. For j = 2 To 6
    
12.     d1(Cells(j, 5).Value) = Cells(j, 6).Value
    
13. Next
    
14. 
    
15. For i = 1 To 110
    
16.     If d2.Exists(Month(arr(i, 1)) & arr(i, 2)) Then
    
17.         d2(Month(arr(i, 1)) & arr(i, 2)) = d2(Month(arr(i, 1)) & arr(i, 2)) + arr(i, 3) * d1(arr(i, 2))
    
18.     Else
    
19.         d2(Month(arr(i, 1)) & arr(i, 2)) = arr(i, 3) * d1(arr(i, 2))
    
20.         list(k, 1) = Month(arr(i, 1)) & "月"
    
21.         list(k, 2) = arr(i, 2)
    
22.         k = k + 1
    
23.     End If
    
24. Next
    
25.    
    
26. For i = 1 To k - 1
    
27.     list(i, 3) = d2(Left(list(i, 1), Len(list(i, 1)) - 1) & list(i, 2))
    
28. Next
    
29. 
    
30. [H2].Resize(UBound(list), 3) = list
    
31. 
    
32. End Sub

复制代码

替伏影子

请阅附件和下载附件测试代码，谢谢！

1. Option Explicit '强制定义变量
   
2. Sub test()
   
3.     Dim arr '定义数组变量 arr
   
4.     Dim brr '定义数组变量 brr
   
5.     Dim i As Byte  '定义变量 i 为 Byte
   
6.     Dim x As Byte  '定义变量 x 为 Byte
   
7.     Dim d As New Dictionary '定义变量d为字典
   
8.     Dim 单价, 月份 As String
   
9.     Range("H2:J48").Clear '先清空单元格
   
10.     arr = Sheets("Sheet1").[A1].CurrentRegion
    
11.     For i = 2 To UBound(arr, 1)
    
12.         月份 = Month(arr(i, 1)) & "月" '取得月份
    
13.         '取得单价
    
14.         If arr(i, 2) = Range("E2") Then
    
15.             单价 = Range("F2")
    
16.         ElseIf arr(i, 2) = Range("E3") Then
    
17.             单价 = Range("F3")
    
18.         ElseIf arr(i, 2) = Range("E4") Then
    
19.             单价 = Range("F4")
    
20.         ElseIf arr(i, 2) = Range("E5") Then
    
21.             单价 = Range("F5")
    
22.         ElseIf arr(i, 2) = Range("E6") Then
    
23.             单价 = Range("F6")
    
24.         End If
    
25.         '字典加载数据，进行汇总
    
26.         d(月份 & "|" & Cells(i, 2)) = d(月份 & "|" & Cells(i, 2)) + Cells(i, 3) * 单价
    
27.     Next i
    
28.     ReDim brr(d.Count, 1 To 3)
    
29.     For x = 0 To d.Count - 1
    
30.         brr(x, 1) = Split(d.Keys(x), "|")(0)
    
31.         brr(x, 2) = Split(d.Keys(x), "|")(1)
    
32.         brr(x, 3) = d.Items(x)
    
33.     Next x
    
34.     Range("H2").Resize(d.Count, 3) = brr
    
35. End Sub
    

复制代码

wangfengren

Sub aa()    '作业代码写在该模块
  Dim d As New Dictionary
  Dim i As Integer, j As Integer, str As String, arr, brr(0 To 110, 1 To 3)
  arr = Range("a2:c111")
  For i = 1 To 110
    str = Month(arr(i, 1)) & "|" & arr(i, 2)
    d(str) = d(str) + arr(i, 3) * Application.WorksheetFunction.VLookup(arr(i, 2), Range("e2:f6"), 2, 0)
  Next i
For j = 0 To d.Count - 1
    brr(j, 1) = Split(d.Keys(j), "|")(0)
    brr(j, 2) = Split(d.Keys(j), "|")(1)
    brr(j, 3) = d.Items(j)
  Next j
  Range("h2").Resize(d.Count, 3) = brr
End Sub

0Mouse

第2讲-A21-0Mouse，有劳吴姐！

1. 
   
2. Sub aa()
   
3.     Dim arr, brr, d1 As Object, d2 As Object, i%, j%, crr, drr, err, k%
   
4.     With Sheet1
   
5.         arr = .Range("E2:F" & .Range("E2").End(xlDown).Row)
   
6.         brr = .Range("A2:C" & .Cells(Rows.Count, 1).End(xlUp).Row)
   
7.     End With
   
8.     Set d1 = CreateObject("scripting.dictionary")
   
9.     Set d2 = CreateObject("scripting.dictionary")
   
10.     For i = 1 To UBound(arr)
    
11.         d1(arr(i, 1)) = arr(i, 2)
    
12.     Next
    
13.     ReDim crr(1 To UBound(brr), 1 To 3)
    
14.     For j = 1 To UBound(brr)
    
15.         d2(Month(brr(j, 1)) & vbTab & brr(j, 2)) = d2(Month(brr(j, 1)) & vbTab & brr(j, 2)) + brr(j, 3) * d1(brr(j, 2))
    
16.     Next
    
17.     crr = d2.Keys
    
18.     drr = d2.Items
    
19.     ReDim err(1 To d2.Count, 1 To 3)
    
20.     For k = 1 To d2.Count
    
21.         err(k, 1) = Split(crr(k - 1), vbTab)(0) & "ÔÂ"
    
22.         err(k, 2) = Split(crr(k - 1), vbTab)(1)
    
23.         err(k, 3) = drr(k - 1)
    
24.     Next
    
25.     Sheet1.Range("H2:J" & Rows.Count - 1).ClearContents
    
26.     Sheet1.Range("H2").Resize(d2.Count, 3) = err
    
27.     Set d1 = Nothing: Set d2 = Nothing
    
28.     Erase arr: Erase brr: Erase crr: Erase drr: Erase err
    
29. End Sub

复制代码

1. 
   
2. Sub bb()
   
3.     Dim arr, brr, d1 As Object, d2 As Object, i%, j%, crr
   
4.     With Sheet1
   
5.         arr = .Range("E2:F" & .Range("E2").End(xlDown).Row)
   
6.         brr = .Range("A2:C" & .Cells(Rows.Count, 1).End(xlUp).Row)
   
7.     End With
   
8.     Set d1 = CreateObject("scripting.dictionary")
   
9.     Set d2 = CreateObject("scripting.dictionary")
   
10.     For i = 1 To UBound(arr)
    
11.         d1(arr(i, 1)) = arr(i, 2)
    
12.     Next
    
13.     ReDim crr(1 To UBound(brr), 1 To 3)
    
14.     For j = 1 To UBound(brr)
    
15.         If Not d2.Exists(Month(brr(j, 1)) & vbTab & brr(j, 2)) Then
    
16.             d2.Add Month(brr(j, 1)) & vbTab & brr(j, 2), d2.Count + 1
    
17.         End If
    
18.         crr(d2(Month(brr(j, 1)) & vbTab & brr(j, 2)), 1) = Month(brr(j, 1)) & "月"
    
19.         crr(d2(Month(brr(j, 1)) & vbTab & brr(j, 2)), 2) = brr(j, 2)
    
20.         crr(d2(Month(brr(j, 1)) & vbTab & brr(j, 2)), 3) = crr(d2(Month(brr(j, 1)) & vbTab & brr(j, 2)), 3) + brr(j, 3) * d1(brr(j, 2))
    
21.     Next
    
22.     Sheet1.Range("H2:J" & Rows.Count - 1).ClearContents
    
23.     Sheet1.Range("H2").Resize(d2.Count, 3) = crr
    
24.     Set d1 = Nothing: Set d2 = Nothing
    
25.     Erase arr: Erase brr: Erase crr
    
26. End Sub

复制代码

答卷： 第2讲-A21-0Mouse.rar (33.14 KB, 下载次数: 18)

2012-6-9 19:46 上传

点击文件名下载附件
字典2讲-A21-0Mouse

chen1237777

201201字典班第二讲作业.xls (63 KB, 下载次数: 12)

2012-6-9 20:53 上传

点击文件名下载附件 吴姐 我又来 走后门了 你·懂得 要手下留情哈

ldxhzy

蹭网交作业！请老师批改！

sgyzzz

第二讲-A14-sgyzzz.rar (31.61 KB, 下载次数: 9)

2012-6-10 09:13 上传

点击文件名下载附件