【字典201201班】B组（B01—B22）第1讲作业上交贴

rhr2008

rhr2008交201201字典班第一讲作业，请老师批阅，谢谢！
Sub aa数组()    '作业代码写在该模块
    Dim d As New Dictionary
    Dim i As Integer
    Dim r As Integer
    Dim arr
    r = Range("A65536").End(xlUp).Row
    arr = Range("A2:C" & r)
    For i = 1 To UBound(arr, 1)
        If arr(i, 2) = Range("G1") Then
            d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3)
        End If
         If Range("G1") = "全部" Then
            d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3)
        End If
    Next i
    Range("F2:G15").ClearContents
    Range("F2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Keys)
    Range("G2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Items)
End Sub

飞天小猪

交作业了，第1讲-B16-飞天小猪

sclxc

上交作业，请老师批阅

YESS95

来下载作业，十六字。
Sub aa() '作业代码写在该模块
    Dim i As Integer
    Dim arr()
    Dim obj
    Dim str As String
    With Sheet1
    str = .[g1].Value
    arr = .Range(.[a2], .Cells(Rows.Count, "c").End(xlUp)).Value
        Set obj = CreateObject("scripting.dictionary")
        For i = 1 To UBound(arr, 1)
        If str = "全部" Then
            obj(arr(i, 1)) = arr(i, 3) + obj(arr(i, 1))
        ElseIf arr(i, 2) = str Then obj(arr(i, 1)) = arr(i, 3) + obj(arr(i, 1))
        End If
        Next i
        .[f3:g15].ClearContents
        .[f3].Resize(obj.Count, 1) = WorksheetFunction.Transpose(obj.keys)
        .[g3].Resize(obj.Count, 1) = WorksheetFunction.Transpose(obj.items)
    End With
End Sub

liuxingyi88

【字典.B13】liu   交作业。
出差了，没听到课，也没请假，请谅解！！！
谢谢！！！

银鱼

作业谁想出来的，太难了吧，花了3天时间才勉强做出来。

1. 
   
2.   Dim i As Integer
   
3.   Dim arr
   
4.   Dim d
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Sheets("sheet1")
   
7.         arr = .[a1].CurrentRegion
   
8.         For i = 2 To UBound(arr)
   
9.             If .[g1] = "全部" Then
   
10.                 d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3)
    
11.             ElseIf arr(i, 2) = .Range("g1").Text Then
    
12.                 d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3)
    
13.             End If
    
14.         Next
    
15.         .[f2].Resize(d.Count) = Application.Transpose(d.keys)
    
16.         .[g2].Resize(d.Count) = Application.Transpose(d.items)
    
17.     End With
    

复制代码

ゅ閪閪ヘ

第1讲-B12-ゅ閪閪ヘ.zip (17.85 KB, 下载次数: 5)

2012-6-3 22:25 上传

点击文件名下载附件

fjmxwrs

第1讲-B06-fjmxwrs.rar (19.94 KB, 下载次数: 20)

2012-6-4 14:07 上传

点击文件名下载附件

从从容容

第1讲-B11-从从容容.rar (18.65 KB, 下载次数: 19)

2012-6-4 17:58 上传

点击文件名下载附件

ilyou2049

1. 
   
2. Sub aa() '作业代码写在该模块
   
3.     Dim d As New Dictionary
   
4.     Dim i As Long
   
5.     Range("f2:g15").Value = ""
   
6.   
   
7.   For i = 2 To 111
   
8.     d(Cells(i, 1).Value) = d(Cells(i, 1).Value) + Cells(i, 3).Value
   
9.   Next i
   
10.   
    
11.   If (Range("g1").Value = "全部") Then
    
12.     Range("f2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Keys)
    
13.     Range("g2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Items)
    
14. Else
    
15.     d.RemoveAll
    
16.     For i = 2 To 111
    
17.         If (Cells(i, 2).Value = Range("g1").Value) Then
    
18.             d(Cells(i, 1).Value) = d(Cells(i, 1).Value) + Cells(i, 3).Value
    
19.             Range("f2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Keys)
    
20.             Range("g2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Items)
    
21.         End If
    
22.     Next i
    
23. End If
    
24. 
    
25.     d.RemoveAll
    
26.   
    
27. End Sub
    
28. 
    

复制代码