【字典201201班】B组（B01—B22）第3讲作业上交贴
本帖最后由 liuguansky 于 2012-6-21 08:43 编辑注意：
1：作业尽量通过自己思考独立完成，不会的可在同学之间私聊讨论，禁止在QQ群公开讨论。
2：本帖已经设置仅作者可见，作业可以以压缩附件形式或者直接贴代码提交。（压缩文件名格式：第1讲-B01-论坛ID）
3：非本组学员作业不得交于此处，不得为抢沙发而占位，不得跟灌水帖，违者扣分。
4：上交作业截止时间：2012年6月19日18：00。
5：补交作业截止时间：2012年6月20日18：00。（只记考勤，不做批改） 本帖最后由 sclxc 于 2012-6-15 11:47 编辑
Sub zd2()
Dim d As New Dictionary
Dim i As Long
Dim arr
Range("E2:F65536").ClearContents
arr = Range("A2:B" & Range("A65536").End(xlUp).Row)
For i = 1 To UBound(arr)
If arr(i, 1) = "" Then
arr(i, 1) = arr(i - 1, 1)
End If
Next i
For i = 1 To UBound(arr)
If arr(i, 2) >= 100 And (arr(i, 2)) <= 400 Then
d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
End If
Next i
Range("E2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Keys)
Range("F2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Items)
End Sub
Sub zd1()
Dim d As New Dictionary
Dim i As Long
Dim arr, arr1
arr = Range("A2:B" & Range("B65536").End(xlUp).Row)
arr1 = Range("E2:E" & Range("E65536").End(xlUp).Row)
Range("F2:F65536").ClearContents
For i = 1 To UBound(arr1)
If d.Exists(arr1(i, 1)) = False Then
d(arr1(i, 1)) = d.Count + 2
End If
Next i
For i = 1 To UBound(arr)
If d.Exists(arr(i, 1)) = False Then
d(arr(i, 1)) = d.Count + 2
Cells(d.Count + 1, "D") = d.Count
Cells(d.Count + 1, "E") = arr(i, 1)
Cells(d.Count + 1, "D").Font.Bold = True
Cells(d.Count + 1, "E").Font.Bold = True
End If
Next i
For i = 1 To UBound(arr)
Cells(d(arr(i, 1)), "F") = Cells(d(arr(i, 1)), "F") + arr(i, 2)
Next i
End Sub
上交第三课作业。 学委，第二题，我们纠结于到底是先全部汇总后现判断呢，还是逐行进行判断。
本题的答案是，逐行进行判断，然后汇总。
若有问题，请指正，但下次，这种容易混的题是否可以贴张结果出来，谢谢了。
B22我不知道呀交作业!
本帖最后由 我不知道呀 于 2012-6-15 20:41 编辑第一题代码:
Sub aa2()
Dim d As New Dictionary
Dim d1 As New Dictionary
Dim i As Long, j As Long, z As Long, z1 As Long
Dim arr()
Dim arr1
For j = 2 To Sheet1.Range("d65536").End(xlUp).Row
d1(Cells(j, 5).Value) = ""
Next j
For i = 2 To Sheet1.Range("a65536").End(xlUp).Row
d(Cells(i, 1).Value) = ""
Next i
For i = 2 To Sheet1.Range("a65536").End(xlUp).Row
If d1.Exists(Cells(i, 1).Value) = False Then
d1(Cells(i, 1).Value) = d1.Count + 1
Cells(d1(Cells(i, 1).Value) + 1, 4) = d1(Cells(i, 1).Value)
Cells(d1(Cells(i, 1).Value) + 1, 4).Font.Bold = True
Cells(d1(Cells(i, 1).Value) + 1, 5) = d1.Keys(d1(Cells(i, 1).Value) - 1)
Cells(d1(Cells(i, 1).Value) + 1, 5).Font.Bold = True
End If
Next i
ReDim arr(1 To d.Count, 1 To 3)
d.RemoveAll
For i = 2 To Sheet1.Range("a65536").End(xlUp).Row
If d.Exists(Cells(i, 1).Value) = False Then
d(Cells(i, 1).Value) = d.Count + 1
arr(d(Cells(i, 1).Value), 1) = d(Cells(i, 1).Value)
arr(d(Cells(i, 1).Value), 2) = d.Keys(d(Cells(i, 1).Value) - 1)
arr(d(Cells(i, 1).Value), 3) = Cells(i, 2)
Else
arr(d(Cells(i, 1).Value), 3) = arr(d(Cells(i, 1).Value), 3) + Cells(i, 2)
End If
Next i
arr1 = Range("d2:F" & d.Count + 1)
For z = 1 To d.Count
For z1 = 1 To Sheet1.Range("d65536").End(xlUp).Row - 1
If arr(z, 2) = arr1(z1, 2) Then
arr1(z1, 3) = arr(z, 3)
End If
Next z1
Next z
Range("D2").Resize(d.Count, 3) = arr1
End Sub
------------------------------------------------------------------------------------------------------------------------------------------------------------
第二题代码:
Sub bb()
Dim d As New Dictionary
Dim x As Long
Dim r As Integer
Dim mergestr As String
Dim MergeCot As Integer
Dim arr()
Dim i As Integer
Dim j As Integer
With Sheet2
r = .Cells(.Rows.Count, 1).End(xlUp).Row
ReDim arr(1 To r - 1, 1 To 1)
For i = 2 To r
mergestr = .Cells(i, 1).Value
MergeCot = .Cells(i, 1).MergeArea.Count
For j = 1 To MergeCot
arr(i - 1, 1) = mergestr
i = i + 1
Next j
i = i - 1
Next i
End With
Sheet2.Range("E2:F1000").ClearContents
For x = 2 To 111
If d.Exists(arr(x - 1, 1)) = False Then
d(arr(x - 1, 1)) = d.Count + 2
Cells(d(arr(x - 1, 1)), 5) = arr(x - 1, 1)
If Sheet2.Cells(x, 2) >= 100 And Sheet2.Cells(x, 2) <= 400 Then Sheet2.Cells(d(arr(x - 1, 1)), 6) = Sheet2.Cells(x, 2)
Else
If Sheet2.Cells(x, 2) >= 100 And Sheet2.Cells(x, 2) <= 400 Then
Sheet2.Cells(d(arr(x - 1, 1)), 6) = Sheet2.Cells(d(arr(x - 1, 1)), 6) + Sheet2.Cells(x, 2)
End If
End If
Next x
End Sub
B：21小志上交作业。
谢谢批改，辛苦了。。
本帖最后由 fjmxwrs 于 2012-6-20 13:36 编辑
谢谢老师的批改，可否详细讲解一下存在的问题？
本帖最后由 从从容容 于 2012-6-16 09:37 编辑
Sub 第一题()
Dim d1 As New Dictionary
Dim d2 As New Dictionary
Dim d3 As New Dictionary
Dim x, i As Integer
Dim arr, arr1
With Sheets("题1")
arr = .Range("A2:B" & .Range("A65536").End(3).Row)
arr1 = .Range("E2:E" & Range("e65536").End(3).Row)
For x = 1 To UBound(arr1)
For i = 1 To UBound(arr)
If arr1(x, 1) = arr(i, 1) Then
d1(arr1(x, 1)) = d1(arr1(x, 1)) + arr(i, 2)
End If
Next i
Next x
..Resize(d1.Count) = Application.Transpose(d1.Items)
For x = 1 To UBound(arr)
If d1.Exists(arr(x, 1)) = False Then
d2(arr(x, 1)) = d2(arr(x, 1)) + arr(x, 2)
End If
If d3.Exists(arr(x, 1)) = False Then
d3(arr(x, 1)) = d3.Count + d1.Count + 1
End If
Next x
.Range("D" & ..End(3).Row).Offset(1).Resize(d2.Count) = Application.Transpose(d3.Items)
.Range("E" & ..End(3).Row).Offset(1).Resize(d2.Count) = Application.Transpose(d2.Keys)
.Range("F" & ..End(3).Row).Offset(1).Resize(d2.Count) = Application.Transpose(d2.Items)
.Range(Cells(d1.Count + 2, 4), Cells(d2.Count + d1.Count + 1, 6)).Font.Bold = True
End With
End Sub
Sub 第二题()
Dim d As New Dictionary
Dim x, i As Integer
Dim arr
arr = Range("A2:B" & Range("A65536").End(3).Row)
For x = 1 To UBound(arr)
If arr(x, 1) = "" Then
arr(x, 1) = arr(x - 1, 1)
End If
Next x
For i = 1 To UBound(arr)
If arr(i, 2) >= Range("C2") And arr(i, 2) <= Range("D2") Then
d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
End If
Next i
Range("e2").Resize(d.Count, 1) = Application.Transpose(d.Keys)
Range("f2").Resize(d.Count, 1) = Application.Transpose(d.Items)
End Sub
Sub 题1()
Dim i As Long, j As Long, k As Long
Dim arr '存放A、B列原始数据数组
Dim arr_Y '存放E列固定省份数组
Dim d
Set d = CreateObject("scripting.dictionary")
arr = Range("A2:B" & .End(xlUp).Row)
arr_Y = Range("E2:E9")
For i = 1 To UBound(arr_Y)'为不改变序号1-8行数据，先将固定省份装入字典，项值为0
d(arr_Y(i, 1)) = 0
Next
For j = 1 To UBound(arr)
d(arr(j, 1)) = d(arr(j, 1)) + arr(j, 2)
Next
Range("D10:E65536") = ""
Range("F2:F65536") = ""
Range("D10:E65536").Font.Bold = False
Range("E2").Resize(d.Count) = Application.Transpose(d.keys)
Range("F2").Resize(d.Count) = Application.Transpose(d.Items)
If d.Count > 8 Then
For k = 9 To d.Count
Cells(k + 1, "D") = k '新增序号
Next
Range("D10:E" & k).Font.Bold = True '新增序号、地区加粗显示
End If
Set d = Nothing
End SubSub 题2()
Dim i As Long
Dim arr
Dim d
Set d = CreateObject("scripting.dictionary")
arr = Range("A2:B" & .End(xlUp).Row)
For i = 1 To UBound(arr)
If arr(i, 1) = "" Then '补充因合并单元格造成的地区空值
arr(i, 1) = arr(i - 1, 1)
End If
If arr(i, 2) < 100 Or arr(i, 2) > 400 Then'除去小于100或大于400的值
arr(i, 2) = 0
End If
d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
Next
Range("E2:F65536") = ""
Range("E2").Resize(d.Count) = Application.Transpose(d.keys)
Range("F2").Resize(d.Count) = Application.Transpose(d.Items)
End Sub
页:
[1]
2