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

wcymiss

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

心灯芯

第一次沙发交作业 201201字典班第三讲作业-心灯芯.rar (15.07 KB, 下载次数: 20)

2012-6-15 15:10 上传

点击文件名下载附件

panan12320

第一题
Sub dfg()
    Dim i%, a1(), a2()
    Set d = CreateObject("scripting.dictionary")
    Sheets("题2").Range("e2:f65536").ClearContents
    a1 = Range("a2:b" & Range("a65536").End(3).Row)
    a2 = Range("d2:e" & Range("e65536").End(3).Row)
    Range("D1:F65536").Font.Bold = False
    k = UBound(a2, 1)
    For i = 1 To UBound(a2, 1)
        d(a2(i, 1)) = a2(i, 2)
        d(a2(i, 2)) = "0"
    Next
    For i = 1 To UBound(a1, 1)
        If d.exists(a1(i, 1)) Then
            d(a1(i, 1)) = d(a1(i, 1)) + a1(i, 2)
        Else
            k = k + 1
            d.Add k, a1(i, 1)
            d.Add a1(i, 1), a1(i, 2)
        End If
    Next
    ReDim a3(1 To d.Count / 2, 1 To 3)
    For i = 1 To d.Count / 2
        a3(i, 1) = i
        a3(i, 2) = d(i)
        a3(i, 3) = d(a3(i, 2))
    Next
    [d2].Resize(UBound(a3, 1), UBound(a3, 2)) = a3
    Range("D" & UBound(a2, 1) + 2 & ":F" & Range("e65536").End(3).Row + 1).Font.Bold = True
End Sub

第二题

Sub UI()
Dim i%, arr()
    Set d = CreateObject("scripting.dictionary")
    Sheets("题2").Range("e2:f65536").ClearContents
    arr = Range("a2:b" & Range("a65536").End(3).Row)
    For i = 1 To UBound(arr, 1)
        If arr(i, 1) = "" Then arr(i, 1) = arr(i - 1, 1)
        If arr(i, 2) >= [c2] And arr(i, 2) <= [d2] Then
            d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
        End If
    Next
    [E2].Resize(d.Count, 1) = Application.Transpose(d.keys)
    [F2].Resize(d.Count, 1) = Application.Transpose(d.items)
End Sub
重新写了第一题

Sub du()
    Dim i%, a1(), a2(), a3(1 To 6000, 1 To 3)
    Set d = CreateObject("scripting.dictionary")
    Sheets("题2").Range("e2:f65536").ClearContents
    a1 = Range("a2:b" & Range("a65536").End(3).Row)
    a2 = Range("d2:e" & Range("e65536").End(3).Row)
    Range("D1:F65536").Font.Bold = False
    k = UBound(a2, 1)
    For i = 1 To UBound(a2, 1)
        d(a2(i, 2)) = a2(i, 1)
        a3(d(a2(i, 2)), 1) = a2(i, 1)
        a3(d(a2(i, 2)), 2) = a2(i, 2)
    Next
    For i = 1 To UBound(a1, 1)
        If d.exists(a1(i, 1)) Then
            a3(d(a1(i, 1)), 3) = a3(d(a1(i, 1)), 3) + a1(i, 2)
        Else
            d(a1(i, 1)) = d.Count + 1
            a3(d(a1(i, 1)), 1) = d(a1(i, 1))
            a3(d(a1(i, 1)), 2) = a1(i, 1)
            a3(d(a1(i, 1)), 3) = a3(d(a1(i, 1)), 3) + a1(i, 2)
        End If
    Next
    [d2].Resize(UBound(a3, 1), UBound(a3, 2)) = a3
    Range("D" & UBound(a2, 1) + 2 & ":F" & Range("e65536").End(3).Row + 1).Font.Bold = True
End Sub

周义坤

第一题：

1. Sub ek_sky()
   
2. Dim arr1, arr2, arr3
   
3. Dim i&, j&, k&, l&
   
4. Dim d1 As New Dictionary
   
5. arr1 = Range("D2:E9")
   
6. arr2 = Range("A1").CurrentRegion
   
7.     For i = 1 To 8
   
8.     d1(arr1(i, 2)) = 0
   
9.     Next i
   
10.         For j = 2 To UBound(arr2)
    
11.         d1(arr2(j, 1)) = d1(arr2(j, 1)) + arr2(j, 2)
    
12.         Next j
    
13.             Range("E2").Resize(d1.Count) = Application.Transpose(d1.Keys)
    
14.             Range("F2").Resize(d1.Count) = Application.Transpose(d1.Items)
    
15. ReDim arr3(1 To d1.Count, 1 To 1)
    
16.         For k = 1 To d1.Count
    
17.         arr3(k, 1) = k
    
18.         Next k
    
19. Range("D2").Resize(d1.Count) = arr3
    
20.     For l = 2 To d1.Count + 1
    
21.         If l > 8 Then
    
22.             Range("D" & l & ":F" & l).Font.Bold = True
    
23.         End If
    
24.     Next l
    
25.     Set arr1 = Nothing
    
26.         Set arr2 = Nothing
    
27.             Set d1 = Nothing
    
28. End Sub
    

复制代码

第二题：

1. Sub ek_kw()
   
2. Dim arr1, arr2, arr3
   
3. Dim i&, j&
   
4. Dim d2 As New Dictionary
   
5. arr1 = Range("A1:B" & Cells(Rows.Count, 2).End(3).Row)
   
6. arr2 = Range("C2:D2")
   
7.     For i = 2 To UBound(arr1)
   
8.         If arr1(i, 1) = "" Then
   
9.             arr1(i, 1) = arr1(i - 1, 1)
   
10.                 End If
    
11.     Next i
    
12.     For j = 2 To UBound(arr1)
    
13.         If arr1(j, 2) >= arr2(1, 1) And arr1(j, 2) <= arr2(1, 2) Then
    
14.             d2(arr1(j, 1)) = d2(arr1(j, 1)) + arr1(j, 2)
    
15.                 End If
    
16.     Next j
    
17. Range("E2").Resize(d2.Count) = Application.Transpose(d2.Keys)
    
18. Range("F2").Resize(d2.Count) = Application.Transpose(d2.Items)
    
19. Set arr1 = Nothing
    
20.     Set arr2 = Nothing
    
21.         Set d2 = Nothing
    
22. End Sub
    

复制代码

ldxhzy

交作业 了！好象不太难。

wangfengren

Sub t1()
    Dim d As New Dictionary
    Dim i As Integer
    For i = 2 To 9
        d(Cells(i, "E").Value) = d.Count + 1
    Next i
    For i = 2 To Range("a35536").End(xlUp).Row
    If d.Exists(Cells(i, 1).Value) = False Then
        d(Cells(i, 1).Value) = d.Count + 1
         Cells(d(Cells(i, 1).Value) + 1, "d").Value = d(Cells(i, 1).Value)
        Cells(d(Cells(i, 1).Value) + 1, "d").Font.Bold = True
        Cells(d(Cells(i, 1).Value) + 1, "E").Value = Cells(i, 1).Value
        Cells(d(Cells(i, 1).Value) + 1, "E").Font.Bold = True
        Cells(d(Cells(i, 1).Value) + 1, "F").Font.Bold = True
     End If
        Cells(d(Cells(i, 1).Value) + 1, "F").Value = Cells(d(Cells(i, 1).Value) + 1, "F").Value + Cells(i, 2).Value
    Next i
   
End Sub

Sub t2()
Dim d As New Dictionary
Dim arr(1 To 110, 1 To 2)
Dim i As Integer
For i = 1 To 110
    arr(i, 1) = Cells(i + 1, 1).Value
    arr(i, 2) = Cells(i + 1, 2).Value
    If IsEmpty(arr(i, 1)) Then
        arr(i, 1) = arr(i - 1, 1)
    End If
    d(arr(i, 1)) = arr(i, 2)
    If d(arr(i, 1)) >= 100 And d(arr(i, 1)) <= 400 Then
        d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
    End If
Next i
Range("e2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Keys)
Range("F2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Items)
End Sub

byhdch

1. 
   
2. 
   
3. Sub 第一题汇总()
   
4.     Dim i As Long
   
5.     Dim d As New Dictionary
   
6.     Dim arr, arr1(1 To 10000, 1 To 3), arr2
   
7.     arr = Array("吉林省", "湖北省", "辽宁省", "海南省", "湖南省", "江西省", "四川省", "广西省")
   
8.     For i = 0 To UBound(arr)
   
9.         d(arr(i)) = d.Count + 1
   
10.         arr1(d.Count, 2) = arr(i)
    
11.         arr1(d.Count, 1) = d.Count
    
12.     Next i
    
13.     arr2 = Range("a2:b" & Range("b65536").End(xlUp).Row)
    
14.     For i = 1 To UBound(arr2)
    
15.         If d.Exists(arr2(i, 1)) = False Then
    
16.             d(arr2(i, 1)) = d.Count + 1
    
17.             arr1(d.Count, 2) = arr2(i, 1)
    
18.             arr1(d.Count, 3) = arr2(i, 2)
    
19.             arr1(d.Count, 1) = d.Count
    
20.         Else
    
21.             arr1(d(arr2(i, 1)), 3) = arr1(d(arr2(i, 1)), 3) + arr2(i, 2)
    
22.         End If
    
23.     Next i
    
24.     Range("D2:F100").ClearContents
    
25.     Range("D2").Resize(d.Count, UBound(arr1, 2)) = arr1
    
26.     Range("D2:F100").Font.Bold = False
    
27.     For i = 2 To Range("D65536").End(xlUp).Row
    
28.         If Range("D" & i) > UBound(arr) + 1 Then Range("D" & i & ":F" & i).Font.Bold = True
    
29.     Next i
    
30.     Set d = Nothing
    
31. End Sub
    
32. 
    
33. Sub 第二题汇总()
    
34.     Dim i As Long
    
35.     Dim d As New Dictionary
    
36.     Dim arr, arr1(1 To 10000, 1 To 2)
    
37.     arr = Range("a2:b" & Range("b65536").End(xlUp).Row)
    
38.     For i = 1 To UBound(arr)
    
39.         If arr(i, 1) = "" Then arr(i, 1) = arr(i - 1, 1)
    
40.         If d.Exists(arr(i, 1)) = False And arr(i, 2) >= [C2] And arr(i, 2) <= [D2] Then
    
41.             d(arr(i, 1)) = d.Count + 1
    
42.             arr1(d.Count, 1) = arr(i, 1)
    
43.             arr1(d.Count, 2) = arr(i, 2)
    
44.         ElseIf d.Exists(arr(i, 1)) = True And arr(i, 2) >= [C2] And arr(i, 2) <= [D2] Then
    
45.             arr1(d(arr(i, 1)), 2) = arr1(d(arr(i, 1)), 2) + arr(i, 2)
    
46.         End If
    
47.     Next i
    
48.     Range("E2:F100").ClearContents
    
49.     Range("E2").Resize(d.Count, 2) = arr1
    
50.     Set d = Nothing
    
51. End Sub
    
52. 
    

复制代码

第3讲-A20-byhdch.rar (16.28 KB, 下载次数: 8)

2012-6-16 15:52 上传

点击文件名下载附件

tt253605057

第2讲-A04-tt253605057

1. Sub a()    '题1
   
2.     Dim arr, brr, i%, j%, d As Object
   
3.     Sheets("题1").Activate
   
4.     Range("d10:f" & [d65536].End(3).Row + 1).ClearContents
   
5.     arr = Range("a1").CurrentRegion
   
6.     brr = [D1：F9]
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     For i = 2 To UBound(arr)
   
9.         d(arr(i, 1)) = arr(i, 2) + d(arr(i, 1))
   
10.     Next i
    
11.     For j = 2 To UBound(brr)
    
12.         brr(j, 3) = d(brr(j, 2))
    
13.         d.Remove (brr(j, 2))
    
14.     Next j
    
15.     Range("D1").Resize(UBound(brr), 3) = brr
    
16.     If d.Count = 0 Then
    
17.         Exit Sub
    
18.     Else:
    
19.         [D10].Resize(d.Count, 1) = Evaluate(Range("D2:D" & d.Count + 1).Address & "+" & 8)
    
20.         [E10].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
    
21.         [D10].Resize(d.Count, 2).Font.Bold = True
    
22.     End If
    
23. End Sub
    
24. Sub b() '题2
    
25.     Dim a, b, d As Object, arr, i%
    
26.     Sheets("题2").Activate
    
27.     a = [d2]: b = [C2]
    
28.     Set d = CreateObject("scripting.dictionary")
    
29.     arr = Range("a1").CurrentRegion
    
30.     For i = 2 To UBound(arr)
    
31.         If arr(i, 1) = "" Then arr(i, 1) = arr(i - 1, 1)
    
32.         d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2) * (arr(i, 2) > b) * (arr(i, 2) < a)
    
33.     Next i
    
34.     [E2].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
    
35. End Sub

复制代码

xdwy81129

因为涉及事件程序，所以没有附代码了

第3讲-A01-xdwy81129.rar (17.8 KB, 下载次数: 18)

2012-6-17 03:32 上传

点击文件名下载附件

谢谢学委批改

tough2012

提交第三讲作业
第1题
Sub t()
Sheet1.Activate
Application.ScreenUpdating = False
Range("f2:f" & [f65536].End(xlUp).Row).ClearContents
    Dim d As New Dictionary
    Dim i As Byte
        For i = 2 To 9
            d(Cells(i, "e").Value) = i
        Next i
        For i = 2 To [a65536].End(xlUp).Row
            If d.Exists(Cells(i, 1).Value) = False Then
                d(Cells(i, 1).Value) = d.Count + 1
                Cells(d.Count + 1, "d") = d.Count
                Cells(d.Count + 1, "d").Font.Bold = True
                Cells(d.Count + 1, "e") = Cells(i, 1)
                Cells(d.Count + 1, "e").Font.Bold = True
                Cells(d.Count + 1, "f") = Cells(i, 2)
             Else
                Cells(d(Cells(i, 1).Value), "f") = Cells(d(Cells(i, 1).Value), "f") + Cells(i, 2)
            End If
        Next i
Application.ScreenUpdating = True
End Sub

第2题
Sub t2()
Sheet2.Select
Application.ScreenUpdating = False
Range("e2:f" & [f65536].End(xlUp).Row).ClearContents
    Dim d As New Dictionary
    Dim i As Byte
        For i = 2 To 111
            If Cells(i, 1) <> "" Then
                If d.Exists(Cells(i, 1).Value) = False Then
                    d(Cells(i, 1).Value) = d.Count + 2
                    Cells(d.Count + 1, "e") = Cells(i, 1)
                End If
            End If
        Next i
        For i = 2 To 111
            If Cells(i, 1) <> "" And Cells(i, 2) >= Range("c2") And Cells(i, 2) <= Range("d2") Then
                Cells(d(Cells(i, 1).Value), "f") = Cells(d(Cells(i, 1).Value), "f") + Cells(i, 2)
            Else
                If Cells(i, 1) = "" And Cells(i, 2) >= Range("c2") And Cells(i, 2) <= Range("d2") Then
                    Cells(d(Cells(i, 1).End(xlUp).Value), "f") = Cells(d(Cells(i, 1).End(xlUp).Value), "f") + Cells(i, 2)
                End If
            End If
        Next i
Application.ScreenUpdating = True
End Sub