【字典201201班】B组（B01—B22）第2作业上交贴[已批，见A组总结]
本帖最后由 liuguansky 于 2012-6-12 18:29 编辑注意：
1：作业尽量通过自己思考独立完成，不会的可在同学之间私聊讨论，禁止在QQ群公开讨论。
2：本帖已经设置仅作者可见，作业可以以压缩附件形式或者直接贴代码提交。（压缩文件名格式：第1讲-B01-论坛ID）
3：非本组学员作业不得交于此处，不得为抢沙发而占位，不得跟灌水帖，违者扣分。
4：上交作业截止时间：2012年6月12日18：00。
5：补交作业截止时间：2012年6月13日18：00。（只记考勤，不做批改）
B：21小志上交作业。
请老师批改。
你辛苦了。
Option Explicit
Sub aa() '作业代码写在该模块
Dim i As Long, j As Long, x As Long, k As Long
Dim arr '销售日期、品种、数量数组
Dim arr_DJ '品种、单价数组
Dim arr_Tmep1, arr_Tmep2, arr_Tmep3 '临时数组
Dim d
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.Range("A2:C" & Sheet1..End(xlUp).Row)
arr_DJ = Sheet1.Range("E2:F6")
'以下修改数组中的月份和把数量换算为金额
For i = 1 To UBound(arr)
arr(i, 1) = Month(arr(i, 1))
For j = 1 To UBound(arr_DJ)
If arr(i, 2) = arr_DJ(j, 1) Then
arr(i, 3) = arr(i, 3) * arr_DJ(j, 2)
Exit For
End If
Next j
Next i
'以下进行字典拆分
For x = 1 To UBound(arr)
d(arr(x, 1) & "-" & arr(x, 2)) = d(arr(x, 1) & "-" & arr(x, 2)) + arr(x, 3) '
Next
arr_Tmep1 = d.Keys
ReDim arr_Tmep2(1 To d.Count, 1 To 2)
For k = 0 To UBound(arr_Tmep1)
arr_Tmep3 = Split(arr_Tmep1(k), "-")
arr_Tmep2(k + 1, 1) = arr_Tmep3(0)
arr_Tmep2(k + 1, 2) = arr_Tmep3(1)
Next k
'以下写入结果
Sheet1.Range("H2:J65536") = ""
Sheet1.Range("H2").Resize(d.Count, 2) = arr_Tmep2
Sheet1.Range("J2").Resize(d.Count) = Application.Transpose(d.Items)
End Sub B22 我不知道呀 交作业!
sub aa()
Dim arr, arr1
Dim i As Long
Dim x As Long
Dim d As New Dictionary
Range("H2:J100").ClearContents
arr = Range("a2:c111")
For i = 1 To 110
d(Month(arr(i, 1)) & "月" & "|" & arr(i, 2)) = d(Month(arr(i, 1)) & "月" & "|" & arr(i, 2)) + arr(i, 3)
Next i
ReDim arr1(d.Count - 1, 1 To 3)
For x = 0 To d.Count - 1
arr1(x, 1) = Split(d.Keys(x), "|")(0)
arr1(x, 2) = Split(d.Keys(x), "|")(1)
Select Case arr1(x, 2)
Case Is = Cells(2, 5).Value
arr1(x, 3) = d.Items(x) * Cells(2, 6).Value
Case Is = Cells(3, 5).Value
arr1(x, 3) = d.Items(x) * Cells(3, 6).Value
Case Is = Cells(4, 5).Value
arr1(x, 3) = d.Items(x) * Cells(4, 6).Value
Case Is = Cells(5, 5).Value
arr1(x, 3) = d.Items(x) * Cells(5, 6).Value
Case Is = Cells(6, 5).Value
arr1(x, 3) = d.Items(x) * Cells(6, 6).Value
End Select
Next x
Range("h2").Resize(d.Count, 3) = arr1
end sub
本帖最后由 从从容容 于 2012-6-9 09:39 编辑
Sub aa() '作业代码写在该模块
Dim d As New Dictionary
Dim arr, arr1
Dim x, i, j, K As Integer
arr = Range("A2:C111")
arr1 = Range("E2:F6")
Range("h2:j111").ClearContents
For x = 1 To UBound(arr)
arr(x, 1) = Month(arr(x, 1)) & "月"
For i = 1 To UBound(arr1)
If arr(x, 2) = arr1(i, 1) Then
arr(x, 3) = arr(x, 3) * arr1(i, 2)
End If
Next i
Next x
For j = 1 To UBound(arr)
d(arr(j, 1) & "|" & arr(j, 2)) = d(arr(j, 1) & "|" & arr(j, 2)) + arr(j, 3)
Next j
For K = 0 To d.Count - 1
Sheets(1).Cells(K + 2, "H") = Split(d.Keys(K), "|")(0)
Sheets(1).Cells(K + 2, "I") = Split(d.Keys(K), "|")(1)
Next K
Range("J2").Resize(d.Count) = Application.Transpose(d.Items)
End Sub
本帖最后由 sclxc 于 2012-6-9 11:06 编辑
B14上交第2讲作业。 上交第二课作业。
Sub aa() '作业代码写在该模块
Dim 汇总区(1 To 65536, 1 To 3)
Dim arr, sr As String, arr1
Dim row_total As Long, x As Long, y As Long, z As Integer
Dim d As New Dictionary
arr = Range("a2:c" & Range("c" & Cells.Rows.Count).Row)
arr1 = Range("e2:f6")
For x = 1 To UBound(arr)
For z = 1 To UBound(arr1)
If arr1(z, 1) = arr(x, 2) Then arr(x, 3) = arr(x, 3) * arr1(z, 2)
Next z
sr = Month(arr(x, 1)) & "-" & arr(x, 2)
If d.Exists(sr) Then
row_total = d(sr)
汇总区(row_total, 3) = 汇总区(row_total, 3) + arr(x, 3)
Else
y = y + 1
d(sr) = y
汇总区(y, 1) = Month(arr(x, 1)) & "月"
汇总区(y, 2) = arr(x, 2)
汇总区(y, 3) = arr(x, 3)
End If
Next x
Range("h2:j" & d.Count) = 汇总区
End Sub
B04:chenzhi_juan