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

wcymiss · 发表于 2012-5-31 19:53

本帖最后由 wcymiss 于 2012-6-6 19:53 编辑

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

xyf2210 · 发表于 2012-5-31 20:03

Option Explicit
Sub aa() '作业代码写在该模块
Dim arr, d, i, txt
Set d = CreateObject("scripting.dictionary")
txt = Range("g1").Value
arr = Range("a1").CurrentRegion
If txt = "全部" Then
For i = 2 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3)
Next
Else
For i = 2 To UBound(arr)
If arr(i, 2) = txt Then
d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3)
End If
Next
End If
Range("f3").Resize(d.Count, 1) = Application.Transpose(d.keys)
Range("g3").Resize(d.Count, 1) = Application.Transpose(d.items)
Set d = Nothing
End Sub

复制代码

无聊的疯子 · 发表于 2012-5-31 20:29

A22:无聊的疯子来交作业啦!!

第1讲-A22-无聊的疯子.zip (17.54 KB, 下载次数: 31)

w2001pf · 发表于 2012-5-31 23:14

本帖最后由 w2001pf 于 2012-5-31 23:32 编辑

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

chen1237777 · 发表于 2012-5-31 23:40

201201字典班完成.xls (51.5 KB, 下载次数: 10)

周义坤 · 发表于 2012-6-1 08:23

本帖最后由周义坤于 2012-6-2 17:11 编辑

Sub ek_sky()
Dim arr, arr1
Dim i&
Dim k As New Dictionary
arr = Range("A2:C" & Cells(Rows.Count, 1).End(3).Row)
arr1 = Cells(1, "G")
For i = 1 To UBound(arr)
If arr1 = "全部" Then
If arr(i, 2) <> "@" Then
k(arr(i, 1)) = k(arr(i, 1)) + arr(i, 3)
End If
GoTo 100
Else
If arr(i, 2) = arr1 Then
k(arr(i, 1)) = k(arr(i, 1)) + arr(i, 3)
End If
End If
100:
Next i
Range("F3:G15").ClearContents
Range("F3").Resize(k.Count) = Application.Transpose(k.Keys)
Range("g3").Resize(k.Count) = Application.Transpose(k.Items)
End Sub

复制代码

Sub ek_sky()
Dim arr, arr1
Dim i&
Dim k As Object
Set k = CreateObject("scripting.dictionary")
arr = Range("A2:C" & Cells(Rows.Count, 1).End(3).Row)
arr1 = Cells(1, "G")
For i = 1 To UBound(arr)
If IIf(arr1 = "全部", True, arr(i, 2) = arr1) Then
k(arr(i, 1)) = k(arr(i, 1)) + arr(i, 3)
End If
Next i
Range("F2:G15").ClearContents
Range("F3").Resize(k.Count) = Application.Transpose(k.keys)
Range("G3").Resize(k.Count) = Application.Transpose(k.items)
End Sub

复制代码

sliang28 · 发表于 2012-6-1 08:42

不批改啊？{:612:}

0Mouse · 发表于 2012-6-1 09:33

A21：0Mouse答卷，有劳吴姐！

Sub aa() '作业代码写在该模块
Dim arr, Dic As Object, i%
arr = [A2].Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1, 3)
Set Dic = CreateObject("scripting.dictionary")
If [G1].Value = "全部" Then
For i = 1 To UBound(arr, 1)
Dic(arr(i, 1)) = Dic(arr(i, 1)) + arr(i, 3)
Next i
Else
For i = 1 To UBound(arr, 1)
If arr(i, 2) = [G1].Value Then
Dic(arr(i, 1)) = Dic(arr(i, 1)) + arr(i, 3)
End If
Next
End If
[F3:G15].ClearContents
[F3].Resize(Dic.Count, 1) = Application.Transpose(Dic.keys)
[G3].Resize(Dic.Count, 1) = Application.Transpose(Dic.items)
Set Dic = Nothing
Set arr = Nothing
End Sub

复制代码

附件：

第1讲-A21-0Mouse.rar (17.35 KB, 下载次数: 5)

wangfengren · 发表于 2012-6-1 10:04

Sub aa() '作业代码写在该模块
  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

byhdch · 发表于 2012-6-1 18:09

本帖最后由 byhdch 于 2012-6-2 21:56 编辑

第1讲作业 -A20-byhdch
Sub aa()
Dim d As New Dictionary
Dim arr
Dim i As Long
[F3:G15] = ""
arr = Range("A2:C" & [a65536].End(3).Row)
For i = 1 To UBound(arr)
      If [G1] = "全部" Then
         d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3)
      ElseIf arr(i, 2) = [G1] Then
         d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3)
      End If
Next i
[F3].Resize(d.Count, 1) = Application.Transpose(d.Keys)
[G3].Resize(d.Count, 1) = Application.Transpose(d.Items)
End Sub

Sub aa方法2()
Dim d As New Dictionary
Dim i As Long
[F3:G15] = ""
For i = 2 To [a65536].End(3).Row
      If Range("g1").Value = "全部" Then
         d(Cells(i, 1).Value) = d(Cells(i, 1).Value) + Cells(i, 3).Value
      ElseIf Cells(i, 2).Value = Range("g1") Then
         d(Cells(i, 1).Value) = d(Cells(i, 1).Value) + Cells(i, 3).Value
      End If
Next i
[F3].Resize(d.Count, 1) = Application.Transpose(d.Keys)
[G3].Resize(d.Count, 1) = Application.Transpose(d.Items)
End Sub

第1讲-A20-byhdch.rar (16.53 KB, 下载次数: 1)

		自动登录	找回密码
密码			注册

[习题] 【字典201201班】A组（A01—A22）第1讲作业上交贴

评分

相关帖子

点评

评分

评分

评分

评分

评分

评分

评分

评分

评分