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

liuguansky

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

sclxc

1. Sub zd2()
   
2.     Dim d As New Dictionary
   
3.     Dim i As Long
   
4.     Dim arr
   
5.     Range("E2:F65536").ClearContents
   
6.     arr = Range("A2:B" & Range("A65536").End(xlUp).Row)
   
7.     For i = 1 To UBound(arr)
   
8.         If arr(i, 1) = "" Then
   
9.             arr(i, 1) = arr(i - 1, 1)
   
10.         End If
    
11.     Next i
    
12.     For i = 1 To UBound(arr)
    
13.         If arr(i, 2) >= 100 And (arr(i, 2)) <= 400 Then
    
14.             d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
    
15.         End If
    
16.     Next i
    
17.     Range("E2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Keys)
    
18.     Range("F2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Items)
    
19. End Sub

复制代码

1. 
   

复制代码

1. Sub zd1()
   
2.     Dim d As New Dictionary
   
3.     Dim i As Long
   
4.     Dim arr, arr1
   
5.     arr = Range("A2:B" & Range("B65536").End(xlUp).Row)
   
6.     arr1 = Range("E2:E" & Range("E65536").End(xlUp).Row)
   
7.     Range("F2:F65536").ClearContents
   
8.     For i = 1 To UBound(arr1)
   
9.         If d.Exists(arr1(i, 1)) = False Then
   
10.             d(arr1(i, 1)) = d.Count + 2
    
11.         End If
    
12.     Next i
    
13.     For i = 1 To UBound(arr)
    
14.         If d.Exists(arr(i, 1)) = False Then
    
15.             d(arr(i, 1)) = d.Count + 2
    
16.             Cells(d.Count + 1, "D") = d.Count
    
17.             Cells(d.Count + 1, "E") = arr(i, 1)
    
18.             Cells(d.Count + 1, "D").Font.Bold = True
    
19.             Cells(d.Count + 1, "E").Font.Bold = True
    
20.         End If
    
21.     Next i
    
22.     For i = 1 To UBound(arr)
    
23.         Cells(d(arr(i, 1)), "F") = Cells(d(arr(i, 1)), "F") + arr(i, 2)
    
24.     Next i
    
25. End Sub
    

复制代码

蓝天一片云

上交第三课作业。

chenzhi_juan

学委，第二题，我们纠结于到底是先全部汇总后现判断呢，还是逐行进行判断。

本题的答案是，逐行进行判断，然后汇总。

若有问题，请指正，但下次，这种容易混的题是否可以贴张结果出来，谢谢了。

我不知道呀

第一题代码:
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

第3讲-B06-fjmxwrs.rar (19.3 KB, 下载次数: 7)

2012-6-16 02:33 上传

点击文件名下载附件

谢谢老师的批改，可否详细讲解一下存在的问题？

从从容容

1. Sub 第一题()
   
2. Dim d1 As New Dictionary
   
3. Dim d2 As New Dictionary
   
4. Dim d3 As New Dictionary
   
5. Dim x, i As Integer
   
6. Dim arr, arr1
   
7. With Sheets("题1")
   
8. arr = .Range("A2:B" & .Range("A65536").End(3).Row)
   
9. arr1 = .Range("E2:E" & Range("e65536").End(3).Row)
   
10. For x = 1 To UBound(arr1)
    
11. For i = 1 To UBound(arr)
    
12.       If arr1(x, 1) = arr(i, 1) Then
    
13.           d1(arr1(x, 1)) = d1(arr1(x, 1)) + arr(i, 2)
    
14.        End If
    
15. Next i
    
16. Next x
    
17. .[f2].Resize(d1.Count) = Application.Transpose(d1.Items)
    
18. For x = 1 To UBound(arr)
    
19.      If d1.Exists(arr(x, 1)) = False Then
    
20.             d2(arr(x, 1)) = d2(arr(x, 1)) + arr(x, 2)
    
21.       End If
    
22.      If d3.Exists(arr(x, 1)) = False Then
    
23.            d3(arr(x, 1)) = d3.Count + d1.Count + 1
    
24.     End If
    
25. Next x
    
26. .Range("D" & .[d65536].End(3).Row).Offset(1).Resize(d2.Count) = Application.Transpose(d3.Items)
    
27. .Range("E" & .[E65536].End(3).Row).Offset(1).Resize(d2.Count) = Application.Transpose(d2.Keys)
    
28. .Range("F" & .[F65536].End(3).Row).Offset(1).Resize(d2.Count) = Application.Transpose(d2.Items)
    
29. .Range(Cells(d1.Count + 2, 4), Cells(d2.Count + d1.Count + 1, 6)).Font.Bold = True
    
30. End With
    
31. End Sub
    

复制代码

1. Sub 第二题()
   
2. Dim d As New Dictionary
   
3. Dim x, i As Integer
   
4. Dim arr
   
5. arr = Range("A2:B" & Range("A65536").End(3).Row)
   
6. For x = 1 To UBound(arr)
   
7.       If arr(x, 1) = "" Then
   
8.           arr(x, 1) = arr(x - 1, 1)
   
9.        End If
   
10. Next x
    
11. For i = 1 To UBound(arr)
    
12.     If arr(i, 2) >= Range("C2") And arr(i, 2) <= Range("D2") Then
    
13.           d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
    
14.     End If
    
15. Next i
    
16. Range("e2").Resize(d.Count, 1) = Application.Transpose(d.Keys)
    
17. Range("f2").Resize(d.Count, 1) = Application.Transpose(d.Items)
    
18. End Sub

复制代码

第3讲-B11-从从容容D.zip (18.58 KB, 下载次数: 6)

2012-6-16 09:29 上传

点击文件名下载附件

无正

第3讲-B01-无正.rar (14.43 KB, 下载次数: 14)

2012-6-16 19:55 上传

点击文件名下载附件

hainancar

1. Sub 题1()
   
2.     Dim i As Long, j As Long, k As Long
   
3.     Dim arr         '存放A、B列原始数据数组
   
4.     Dim arr_Y       '存放E列固定省份数组
   
5.     Dim d
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     arr = Range("A2:B" & [B65536].End(xlUp).Row)
   
8.     arr_Y = Range("E2:E9")
   
9.    
   
10.     For i = 1 To UBound(arr_Y)  '为不改变序号1-8行数据，先将固定省份装入字典，项值为0
    
11.         d(arr_Y(i, 1)) = 0
    
12.     Next
    
13.     For j = 1 To UBound(arr)
    
14.         d(arr(j, 1)) = d(arr(j, 1)) + arr(j, 2)
    
15.     Next
    
16.    
    
17.     Range("D10:E65536") = ""
    
18.     Range("F2:F65536") = ""
    
19.     Range("D10:E65536").Font.Bold = False
    
20.     Range("E2").Resize(d.Count) = Application.Transpose(d.keys)
    
21.     Range("F2").Resize(d.Count) = Application.Transpose(d.Items)
    
22.    
    
23.     If d.Count > 8 Then
    
24.         For k = 9 To d.Count
    
25.             Cells(k + 1, "D") = k               '新增序号
    
26.         Next
    
27.         Range("D10:E" & k).Font.Bold = True    '新增序号、地区加粗显示
    
28.     End If
    
29.     Set d = Nothing
    
30. End Sub

复制代码

1. Sub 题2()
   
2.     Dim i As Long
   
3.     Dim arr
   
4.     Dim d
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     arr = Range("A2:B" & [B65536].End(xlUp).Row)
   
7.    
   
8.     For i = 1 To UBound(arr)
   
9.         If arr(i, 1) = "" Then                      '补充因合并单元格造成的地区空值
   
10.             arr(i, 1) = arr(i - 1, 1)
    
11.         End If
    
12.         If arr(i, 2) < 100 Or arr(i, 2) > 400 Then  '除去小于100或大于400的值
    
13.             arr(i, 2) = 0
    
14.         End If
    
15.         d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
    
16.     Next
    
17.    
    
18.     Range("E2:F65536") = ""
    
19.     Range("E2").Resize(d.Count) = Application.Transpose(d.keys)
    
20.     Range("F2").Resize(d.Count) = Application.Transpose(d.Items)
    
21. End Sub

复制代码