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

w2001pf

第3讲-A13-w2001pf.rar (19.17 KB, 下载次数: 6)

2012-6-17 11:00 上传

点击文件名下载附件 第3讲-A13-w2001pf

sgyzzz

第三讲A14-sgyzzz.rar (15.48 KB, 下载次数: 2)

2012-6-18 15:18 上传

点击文件名下载附件

1. Sub 第一题()
   
2. Dim d As New dictionary
   
3. Dim d2 As New dictionary
   
4. Dim i As Long
   
5. Dim m As Long
   
6. Dim n As Long
   
7.      Range("d10:f20,f2:f9").ClearContents
   
8.      For i = 2 To Range("d65536").End(xlUp).Row
   
9.         d2(Cells(i, 5).Value) = ""
   
10.      Next i
    
11.      For i = 2 To Range("a65536").End(xlUp).Row
    
12.           d(Cells(i, 1).Value) = d(Cells(i, 1).Value) + Cells(i, 2).Value
    
13.            If d2.Exists(Cells(i, 1).Value) = False Then
    
14.                d2(Cells(i, 1).Value) = d(Cells(i, 1).Value) + Cells(i, 2)
    
15.                n = Range("e65536").End(xlUp).Row + 1
    
16.                Cells(n, "d") = d2.Count
    
17.                Cells(n, "e") = Cells(i, 1)
    
18.             End If
    
19.     Next i
    
20.       Range("d10:f" & d2.Count + 1).Select
    
21.       Selection.Font.Bold = True
    
22.     For m = 0 To d2.Count - 1
    
23.         For n = 0 To d.Count - 1
    
24.             If d2.Keys(m) = d.Keys(n) Then
    
25.                Cells(m + 2, 6) = d.Items(n)
    
26.            End If
    
27.        Next n
    
28.    Next m
    
29.    End Sub
    
30. Sub 第二题()
    
31. Dim d As New dictionary
    
32. Dim i As Long
    
33. Dim arr
    
34.    Range("e2:f20").ClearContents
    
35.    arr = Range("a2:b" & Range("a65536").End(xlUp).Row)
    
36.    For i = 1 To UBound(arr)
    
37.        If arr(i, 1) = "" Then
    
38.           arr(i, 1) = arr(i - 1, 1)
    
39.        End If
    
40.       If arr(i, 2) > Cells(2, 3).Value And arr(i, 2) < Cells(2, 4).Value Then
    
41.          If d.Exists(arr(i, 1)) Then
    
42.             d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
    
43.           Else
    
44.             d.Add arr(i, 1), arr(i, 2)
    
45.           End If
    
46.       End If
    
47.    Next i
    
48.      Range("e2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Keys)
    
49.      Range("f2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Items)
    
50. End Sub

复制代码

zhongnansha2011

第三讲-A19-zhongnansha2011.rar (13.85 KB, 下载次数: 5)

2012-6-18 20:27 上传

点击文件名下载附件

xyf2210

1. Option Explicit
   
2. Sub 题一()
   
3.     Dim x&, arr, arr1, arr2(1 To 1000)
   
4.     Dim d As New Dictionary
   
5.     arr = [a1].CurrentRegion
   
6.     arr1 = [d1].CurrentRegion
   
7.     For x = 2 To UBound(arr1)
   
8.         d.Add arr1(x, 2), arr1(x, 1)
   
9.     Next
   
10.     For x = 2 To UBound(arr)
    
11.         If d.Exists(arr(x, 1)) Then
    
12.             arr2(d(arr(x, 1))) = arr2(d(arr(x, 1))) + arr(x, 2)
    
13.         Else
    
14.             d.Add arr(x, 1), d.Count + 1
    
15.             arr2(d.Count + 1) = arr(x, 2)
    
16.         End If
    
17.     Next
    
18.     Range("d2:f65536").ClearContents
    
19.     [d2].Resize(d.Count) = Application.Transpose(d.Items)
    
20.     [e2].Resize(d.Count) = Application.Transpose(d.Keys)
    
21.     [f2].Resize(d.Count) = Application.Transpose(arr2)
    
22.     Range("d10:f" & d.Count + 1).Font.Bold = True
    
23. End Sub
    
24. Sub 题二()
    
25.     Dim arr, x, y, z, d As New Dictionary
    
26.     arr = Range("a1").CurrentRegion
    
27.     y = [c2]: z = [d2]
    
28.     For x = 2 To UBound(arr)
    
29.         If arr(x, 1) = "" Then arr(x, 1) = arr(x - 1, 1)
    
30.         If d.Exists(arr(x, 1)) And arr(x, 2) > y And arr(x, 2) < z Then
    
31.             d(arr(x, 1)) = d(arr(x, 1)) + arr(x, 2)
    
32.         ElseIf arr(x, 2) > y And arr(x, 2) < z Then
    
33.             d(arr(x, 1)) = arr(x, 2)
    
34.         End If
    
35.     Next x
    
36.     Range("e2:f65536").ClearContents
    
37.     [e2].Resize(d.Count) = Application.Transpose(d.Keys)
    
38.     [f2].Resize(d.Count) = Application.Transpose(d.Items)
    
39. End Sub
    

复制代码

无聊的疯子

A22:无聊的疯子  来交作业了

A22无聊的疯子-201201字典班第三讲作业.zip (14.01 KB, 下载次数: 9)

2012-6-18 21:33 上传

点击文件名下载附件

0Mouse

A21:0Mouse，有劳学委！(*^__^*) 嘻嘻……
题1：

1. Sub One()
   
2. Dim arr, d1 As Object, brr, Ar, i%, j%, d2 As Object
   
3. Set d1 = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. [F2:F9].ClearContents
   
6. Range("D10:F" & Rows.Count - 9).ClearContents
   
7. arr = [D1:F9]
   
8. brr = [A1].CurrentRegion
   
9. ReDim Ar(1 To UBound(brr), 1 To 3)
   
10. For i = 2 To UBound(arr)
    
11.     d1.Add arr(i, 2), arr(i, 1)
    
12. Next
    
13. For j = 2 To UBound(brr)
    
14.     If Not d1.exists(brr(j, 1)) Then
    
15.         If Not d2.exists(brr(j, 1)) Then
    
16.             d2.Add brr(j, 1), d2.Count + 1
    
17.             Ar(d2.Count, 1) = 8 + d2(brr(j, 1))
    
18.             Ar(d2.Count, 2) = brr(j, 1)
    
19.             Ar(d2.Count, 3) = brr(j, 2)
    
20.         Else
    
21.             Ar(d2(brr(j, 1)), 3) = Ar(d2(brr(j, 1)), 3) + brr(j, 2)
    
22.         End If
    
23.     Else
    
24.         arr(d1(brr(j, 1)) + 1, 3) = arr(d1(brr(j, 1)) + 1, 3) + brr(j, 2)
    
25.     End If
    
26. Next
    
27. Range("D1").Resize(9, 3) = arr
    
28. If d2.Count > 0 Then
    
29.     Range("D10").Resize(d2.Count, 3) = Ar
    
30.     [D10].Resize(d2.Count, 2).Font.Bold = True
    
31. End If
    
32. Set d1 = Nothing
    
33. Set d2 = Nothing
    
34. Erase Ar: Erase brr: Erase arr
    
35. Range("D1").Activate
    
36. End Sub

复制代码

题2：

1. 
   
2. Sub Two()
   
3. Dim arr, i%, imin%, imax%, d As Object
   
4. Set d = CreateObject("scripting.dictionary")
   
5. imin = [C2]: imax = [d2]
   
6. arr = Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row)
   
7. For i = 2 To UBound(arr)
   
8.     If arr(i, 1) = "" Then arr(i, 1) = arr(i - 1, 1)
   
9.     If arr(i, 2) >= imin And arr(i, 2) <= imax Then
   
10.         d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
    
11.     End If
    
12. Next
    
13. Range("E2:F" & Rows.Count - 1).ClearContents
    
14. [E2].Resize(d.Count, 1) = Application.Transpose(d.keys)
    
15. [F2].Resize(d.Count, 1) = Application.Transpose(d.items)
    
16. Set d = Nothing
    
17. Erase arr
    
18. End Sub

复制代码

附件： 第3讲-A21-0Mouse.rar (15.16 KB, 下载次数: 5)

2012-6-18 22:54 上传

点击文件名下载附件

chen1237777

这次我是最后一个交作业的 希望不会被发现我舞弊 走后门来了 吴姐 给点可怜分吧
Private Sub Worksheet_Change(ByVal Target As Range)

On Error Resume Next
If Target.Column = 2 And Target.Offset(0, -1) <> "" Then
  Call 第一题
End If
End Sub
Sub 第一题()
Application.EnableEvents = False
On Error Resume Next
Dim d As New Dictionary
Dim arr(1 To 1000, 1 To 3), arr1(), s, k, x
  s = Range("b65536").End(xlUp).Row
  arr1 = Range("a2:b" & s).Value
For x = 2 To 9
k = k + 1
  d(Range("e" & x).Value) = k
  arr(k, 1) = k
  arr(k, 2) = Range("e" & x).Value
  arr(k, 3) = 0
Next x
For x = 1 To UBound(arr1)
If d.Exists(arr1(x, 1)) Then
arr(d(arr1(x, 1)), 3) = arr(d(arr1(x, 1)), 3) + arr1(x, 2)

Else
  k = k + 1
  d(arr1(x, 1)) = k
  arr(k, 2) = arr1(x, 1)
  arr(k, 1) = k
  arr(k, 3) = arr1(x, 2)
End If
Next x
Range("d2").Resize(k, 3) = arr

Range("d10:e" & k + 1).Font.Bold = True
Set d = Nothing
Application.EnableEvents = True
End Sub
Sub 第二题()
On Error Resume Next
Dim d As New Dictionary
Dim arr, arr1(1 To 1000, 1 To 2), s, x, k
  s = Range("b65536").End(xlUp).Row
  arr = Range("a2:b" & s).Value
  s = 0
For x = 1 To UBound(arr)
  If arr(x, 1) = "" Then arr(x, 1) = arr(x - 1, 1)
  If arr(x, 2) >= 100 And arr(x, 2) <= 400 Then
    s = s + 1
    arr1(s, 1) = arr(x, 1)
    arr1(s, 2) = arr(x, 2)
  End If
Next x
For x = 1 To s
  If d.Exists(arr1(x, 1)) Then
    d(arr1(x, 1)) = d(arr1(x, 1)) + arr1(x, 2)
  Else
    d(arr1(x, 1)) = arr1(x, 2)
  End If
Next x
Range("e2").Resize(d.Count) = Application.Transpose(d.Keys)
Range("f2").Resize(d.Count) = Application.Transpose(d.Items)
Set d = Nothing
End Sub

思密达0

做好了，差点忘记交了

替伏影子

作业结果牵强交差
请阅代码或下载附件运行测试,谢谢!

1. Option Explicit
   
2. Sub 第一题()
   
3.     Dim d As Object, d2 As Object, i As Byte, y As Long, u As Long
   
4.     Dim arr1
   
5.     Dim arr2
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set d2 = CreateObject("scripting.dictionary")
   
8.     '先将原先有的省份导入字典，求得序号和省份
   
9.     arr1 = Range("D1:E9")
   
10.     For i = 2 To 9
    
11.         d(arr1(i, 2)) = 0
    
12.         d2(arr1(i, 2)) = arr1(i, 1)  '通过字典d2，求得序号
    
13.         u = d2(arr1(i, 2))
    
14.     Next i
    
15.     '通过字典d2，求得序号和省份
    
16.     arr2 = Range([A1], Cells(Rows.Count, "B").End(xlUp))
    
17.     For i = 2 To UBound(arr2)
    
18.         If d2.exists(Cells(i, 1).Value) = False Then
    
19.             d2(arr2(i, 1)) = d2(arr2(i, 1)) + 1 + u
    
20.             u = u + 1
    
21.         End If
    
22.     Next i
    
23.     '再将数据源继续导入字典d中,求和
    
24.     For i = 2 To UBound(arr2)
    
25.         d(arr2(i, 1)) = d(arr2(i, 1)) + arr2(i, 2)
    
26.     Next i
    
27.     Range("E2").Resize(d.Count, 1) = Application.Transpose(d.keys)
    
28.     Range("F2").Resize(d.Count, 1) = Application.Transpose(d.items)
    
29.     Range("D2").Resize(d2.Count, 1) = Application.Transpose(d2.items)
    
30.     '对新增，进行加粗显示
    
31.     y = Cells(Rows.Count, "E").End(xlUp).Row
    
32.     Range("d10:f" & y).Font.Bold = True
    
33.     Set d = Nothing
    
34.     Set d2 = Nothing
    
35. End Sub
    
36. 
    
37. 
    
38. Sub 第2题答案()
    
39.     Dim arr
    
40.     Dim d As Object
    
41.     Dim i As Integer
    
42.     Set d = CreateObject("scripting.dictionary")
    
43.     Range([E2], Cells(Rows.Count, "F").End(xlUp)).ClearContents
    
44.     Range("E1:f1") = Array("地区", "数量")
    
45.     arr = Range([A1], Cells(Rows.Count, "B").End(xlUp))
    
46.     For i = 2 To UBound(arr)
    
47.         If arr(i, 1) <> "" Then
    
48.             arr(i, 1) = arr(i, 1)
    
49.         Else
    
50.             arr(i, 1) = arr(i - 1, 1)
    
51.         End If
    
52.         If arr(i, 2) >= Range("c2") And arr(i, 2) <= Range("d2") Then
    
53.             d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
    
54.         End If
    
55.     Next i   
    
56.     Range("E2").Resize(d.Count, 1) = Application.Transpose(d.keys)
    
57.     Range("F2").Resize(d.Count, 1) = Application.Transpose(d.items)
    
58.     Set d = Nothing
    
59. End Sub
    
60. 
    

复制代码

sliang28

A17:sliang28
学委，因工作太忙，抽了点时间只完成了第一题，二题没有时间做了，担心来不及先交上第一题答案。

1. Sub huizong()
   
2. Dim d As New Dictionary
   
3. Dim sf, SK
   
4. Dim i, j, k As Integer
   
5.     k = Sheet1.Range("a65536").End(3).Row
   
6.         For i = 2 To k
   
7.             d(Sheet1.Cells(i, 1).Value) = d(Sheet1.Cells(i, 1).Value) + Sheet1.Cells(i, 2).Value
   
8.         Next i
   
9.                 SK = Range("e2:f" & Range("e65536").End(3).Row)
   
10.                     For j = 0 To d.Count
    
11.                         For i = 1 To Sheet1.Range("e65536").End(3).Row - 1
    
12.                             If d.Exists(SK(i, 1)) Then
    
13.                                 If d.Keys(j) = SK(i, 1) Then
    
14.                                     SK(i, 2) = d.Items(j)
    
15.                                         d.Remove (SK(i, 1))
    
16.                                         j = 0
    
17.                                 End If
    
18.                             End If
    
19.                         Next i
    
20.                     Next j
    
21.                 [e2:f9] = SK
    
22.             If d.Count <> 0 Then
    
23.                 Range("e" & Range("e65536").End(3).Row + 1).Resize(d.Count) = Application.WorksheetFunction.Transpose(d.Keys)
    
24.                 Range("f" & Range("f65536").End(3).Row + 1).Resize(d.Count) = Application.WorksheetFunction.Transpose(d.Items)
    
25.             End If
    
26.     For i = 1 To d.Count
    
27.         Range("d" & Range("d65536").End(3).Row + 1) = Range("d" & Range("d65536").End(3).Row) + 1
    
28.     Next i
    
29. End Sub

复制代码