liuguansky 发表于 2012-5-31 19:58

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

本帖最后由 wcymiss 于 2012-6-6 20:14 编辑

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

chenzhi_juan 发表于 2012-5-31 20:00

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

chenzhi_juan 发表于 2012-5-31 20:02

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


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]

第一讲：B04chenzhi_juan

蓝天一片云 发表于 2012-5-31 20:04

上交第一课时作业。

我不知道呀 发表于 2012-5-31 21:12

本帖最后由 我不知道呀 于 2012-5-31 21:16 编辑

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
    .Resize(d1.Count) = Application.WorksheetFunction.Transpose(d1.Keys)
    .Resize(d1.Count) = Application.WorksheetFunction.Transpose(d1.Items)
End Sub

小志 发表于 2012-5-31 21:57

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

晃晃悠悠517 发表于 2012-5-31 22:01

{:1_1:}{:1_1:}{:1_1:}

hainancar 发表于 2012-5-31 22:48

Option Explicit
Sub aa() '作业代码写在该模块
Dim i As Integer
Dim pinZHong As String'品种
Dim arr
Dim d
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.Range("A2:C" & .End(xlUp).Row)
pinZHong = Sheet1.Range("G1").Value
If pinZHong <> "全部" Then
    For i = 1 To UBound(arr)
      If arr(i, 2) = pinZHong Then
      d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3)
      End If
    Next
Else
    For i = 1 To UBound(arr)
      d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3)
    Next
End If
.Resize(d.Count, 1) = Application.Transpose(d.keys)
.Resize(d.Count, 1) = Application.Transpose(d.items)
Set d = Nothing
End Sub

无正 发表于 2012-5-31 23:18

本帖最后由 无正 于 2012-6-1 23:05 编辑

程序作了优化，第一种为分两次判断写入字典，第二种只作一次判断写入字典。

雨后彩霞 发表于 2012-6-1 15:02

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
页: [1] 2 3
查看完整版本: 【字典201201班】B组（B01—B22）第1讲作业上交贴