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

liuguansky

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

chenzhi_juan

我来交作业了哟，请学委查收

chenzhi_juan

啊，不好意思，没有看到压缩的文件名格式，下面是代码：

[code]
Sub aa() '作业代码写在该模块
  Dim arr
    Dim i As Long, a As String
    Dim d As New Dictionary
    arr = Range("A2:c111")
    a = Range("g1").Value
    Range("f3:g15").ClearContents
      If a = "全部" Then
        For i = 1 To UBound(arr, 1)
            d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3)
        Next i
        Else
        For i = 1 To UBound(arr, 1)
          If arr(i, 2) = a Then
            d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3)
             End If
        Next i
       End If
     Range("f3").Resize(d.Count, 1) = Application.Transpose(d.Keys)
     Range("g3").Resize(d.Count, 1) = Application.Transpose(d.Items)
End Sub
[\code]

第一讲：B04  chenzhi_juan

蓝天一片云

上交第一课时作业。

我不知道呀

Sub aa()   
    Dim arr,s,t
    Dim i As Integer, j As Integer
    Dim d As New Dictionary
    Dim d1 As New Dictionary
    arr = Sheet1.Range("A2:c111")
    For i = 1 To 110
        d(arr(i, 1) & arr(i, 2)) = d(arr(i, 1) & arr(i, 2)) + arr(i, 3)
    Next i
    s = d.Keys
    t = d.Items
    For j = 0 To d.Count - 1
        If Right(s(j), 2) = Sheet1.Range("G1").Value Then
            d1(Left(s(j), 3)) = t(j)
        End If
    Next j
    Range("f3:g15").ClearContents
    [f3].Resize(d1.Count) = Application.WorksheetFunction.Transpose(d1.Keys)
    [g3].Resize(d1.Count) = Application.WorksheetFunction.Transpose(d1.Items)
End Sub

小志

B:21小志上交作业。
请老师批改。
您辛苦了。

晃晃悠悠517

hainancar

1. Option Explicit
   
2. Sub aa() '作业代码写在该模块
   
3.   Dim i As Integer
   
4.   Dim pinZHong As String  '品种
   
5.   Dim arr
   
6.   Dim d
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   arr = Sheet1.Range("A2:C" & [C65536].End(xlUp).Row)
   
9.   pinZHong = Sheet1.Range("G1").Value
   
10.   If pinZHong <> "全部" Then
    
11.     For i = 1 To UBound(arr)
    
12.       If arr(i, 2) = pinZHong Then
    
13.         d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3)
    
14.       End If
    
15.     Next
    
16.   Else
    
17.     For i = 1 To UBound(arr)
    
18.       d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3)
    
19.     Next
    
20.   End If
    
21.   [F3].Resize(d.Count, 1) = Application.Transpose(d.keys)
    
22.   [G3].Resize(d.Count, 1) = Application.Transpose(d.items)
    
23.   Set d = Nothing
    
24. End Sub

复制代码

无正

程序作了优化，第一种为分两次判断写入字典，第二种只作一次判断写入字典。
第1讲-B01-无正.rar (18.84 KB, 下载次数: 17)

2012-6-1 23:03 上传

点击文件名下载附件

雨后彩霞

Sub aa()    '作业代码写在该模块
    Dim d As New Dictionary    '引用字典
    Dim i As Long
    Dim y As Range
    Set y = Range("g1")
    Range("f3:g15").ClearContents
    For i = 2 To Range("a65536").End(xlUp).Row
        If y.Value = "全部" Then
            d(Cells(i, 1).Value) = d(Cells(i, 1).Value) + Cells(i, 3)
        ElseIf Cells(i, 2) = y.Value Then
            d(Cells(i, 1).Value) = d(Cells(i, 1).Value) + Cells(i, 3)
        End If
    Next i
    Range("f3").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Keys)
    Range("g3").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Items)
End Sub
Sub ss()
    Dim d As Object
    Set d = CreateObject("scripting.dictionary")    '代码写入字典
    Dim i As Integer, arr, k
    i = Range("a65536").End(xlUp).Row
    arr = Range("a2:c" & i)
    Range("f3:g15").ClearContents '清除内容
    For k = 1 To UBound(arr)
        If Range("g1").Value = "全部" Then
            d(arr(k, 1)) = d(arr(k, 1)) + arr(k, 3)
        ElseIf arr(k, 2) = Range("g1").Value Then
            d(arr(k, 1)) = d(arr(k, 1)) + arr(k, 3)
        End If
    Next k
    Range("f3").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Keys)
    Range("g3").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Items)

End Sub