【VBA字典数组201301班】C组-第五讲作业上交贴

无聊的疯子

【VBA字典数组201301班】C组 - 第五讲作业上交专用，其它成员忽入

作业要求：
    1.要求使用字典完成
    2.所有的代码均写在按钮指定的过程中
    3.要求代码缩进
    4.要求有注释（关键代码处）
    5.要求强制声明

   3-5要求一共占6分，每点2分，2道题最多扣6分

作业上交截止时间：2013年12月11日  20：00
原则上未评分和未开贴前上交均视为有效，不能按时上交的请提前告知！！

雪舞子

1. Sub 作业一()
   
2.     Dim dic As Object, arr, arr1, arr2, brr(), crr(), i&, j%, n&, s$
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     arr = Range("a2").CurrentRegion      '源数据入数组
   
5.     For i = 2 To UBound(arr)
   
6.         dic(arr(i, 1)) = ""              '"地区"去重
   
7.     Next
   
8.     arr1 = dic.Keys                      '"地区"去重后入数组
   
9.     dic.RemoveAll
   
10.     For i = 2 To UBound(arr)
    
11.         dic(arr(i, 2)) = ""              '"品种"去重
    
12.     Next
    
13.     arr2 = dic.Keys                      '"品种"去重后入数组
    
14.     dic.RemoveAll
    
15.         For i = 2 To UBound(arr)
    
16.             s = arr(i, 1) & "-" & arr(i, 2)          '"地区品种"唯一
    
17.             
    
18.                 If Not dic.exists(s) Then            '字典中不存在
    
19.                     n = dic.Count + 1                '字典递加
    
20.                     dic(s) = n                       '递加后存入条目
    
21.                     ReDim Preserve brr(1 To n)       '"地区品种"brr数组随之递增
    
22.                 Else
    
23.                     n = dic(s)                       '字典中存在取出字典序号
    
24.                 End If
    
25.             brr(n) = brr(n) + arr(i, 3)
    
26.             '对应数量累加并存回数组.这里的n即数组下标,也是上面的字典序号,它们是一一对应的
    
27.             
    
28.         Next
    
29.     ReDim crr(UBound(arr1) + 1, UBound(arr2) + 1)    '根据"地区品种"数量重新定义结果数组crr
    
30.     For i = 0 To UBound(arr1)
    
31.         For j = 0 To UBound(arr2)
    
32.         
    
33.             crr(i, j) = brr(dic(arr1(i) & "-" & arr2(j)))
    
34.             '字典序号与brr数组标号一一对应,字典序号存在条目里,与地区品种(key值)一一对应,将其取出依次存入结果数组crr
    
35.             
    
36.             crr(i, UBound(arr2) + 1) = crr(i, UBound(arr2) + 1) + crr(i, j) '行总计
    
37.         Next
    
38.     Next
    
39.     With Range("f1")
    
40.         .CurrentRegion.Offset(1).ClearContents
    
41.         .CurrentRegion.Offset(, 1).ClearContents
    
42.         .Offset(, UBound(arr2) + 2) = "总计"                                '"品种"最后一个偏移位置写上"总计"
    
43.         .Offset(1).Resize(UBound(arr1) + 1) = Application.Transpose(arr1)   '写"地区"
    
44.         .Offset(, 1).Resize(, UBound(arr2) + 1) = arr2                      '写"品种"
    
45.         .Offset(1, 1).Resize(UBound(arr1) + 1, UBound(arr2) + 2) = crr      '输出数据
    
46.     End With
    
47.    
    
48.     MsgBox "作业一完成!" & Chr(13) & Chr(13) & "结果可与透视表一对照", , "友情提示"
    
49.    
    
50. End Sub
    
51. 
    
52. 
    
53. Sub 作业二()
    
54.     Dim dic As Object, arr1, arr2, arr3, brr(), crr, i&, j%, k%, m&, n&, s$
    
55.     Set dic = CreateObject("scripting.dictionary")
    
56.     arr1 = Sheets("作业二").Range("a1").CurrentRegion.Value
    
57.    
    
58.    
    
59.     For i = 2 To UBound(arr1)
    
60.             dic(arr1(i, 2)) = ""              '"地区"去重
    
61.     Next
    
62.     arr2 = dic.Keys                      '"地区"去重后入数组
    
63.     dic.RemoveAll
    
64.     For i = 2 To UBound(arr1)
    
65.         dic(arr1(i, 3)) = ""              '"品种"去重
    
66.     Next
    
67.     arr3 = dic.Keys                      '"品种"去重后入数组
    
68.     dic.RemoveAll
    
69. 
    
70.     For i = 2 To UBound(arr1)
    
71.     m = Month(arr1(i, 1))
    
72. 
    
73.         s = m & "-" & arr1(i, 2) & "-" & arr1(i, 3)       '"月份地区品种"唯一
    
74.         
    
75.             If Not dic.exists(s) Then            '字典中不存在
    
76.                 n = dic.Count + 1                '字典递加
    
77.                     dic(s) = n                       '递加后存入条目
    
78.                 ReDim Preserve brr(1 To n)       '"月份地区品种"brr数组随之递增
    
79.             Else
    
80.                 n = dic(s)                       '字典中存在取出字典序号
    
81.             End If
    
82.         brr(n) = brr(n) + arr1(i, 4)
    
83.         '对应数量累加并存回数组.这里的n即数组下标,也是上面的字典序号,它们是一一对应的
    
84.         
    
85.     Next
    
86.     ReDim crr(UBound(arr2), (UBound(arr3) + 2) * m + 1)
    
87.    
    
88.    
    
89.     For i = 0 To UBound(arr2)
    
90.         For k = 1 To m
    
91.             For j = 0 To UBound(arr3)
    
92.                 If dic.exists(k & "-" & arr2(i) & "-" & arr3(j)) Then
    
93.                     crr(i, (k - 1) * 4 + j) = brr(dic(k & "-" & arr2(i) & "-" & arr3(j)))
    
94.                     '字典序号与brr数组标号一一对应,字典序号存在条目里,与地区品种(key值)一一对应,将其取出依次存入结果数组crr
    
95.                 End If
    
96.                 crr(i, (UBound(arr3) + 2) * k - 1) = crr(i, (UBound(arr3) + 2) * k - 1) + crr(i, (k - 1) * 4 + j)  '行总计
    
97.             Next
    
98.             crr(i, (UBound(arr3) + 2) * m) = crr(i, (UBound(arr3) + 2) * m) + crr(i, (UBound(arr3) + 2) * k - 1)
    
99.         Next
    
100.     Next
     
101.    
     
102.     With Sheets("作业二答案").Range("a1")
     
103.         .CurrentRegion.Clear
     
104.         
     
105.     For i = 1 To m
     
106.         .Offset(, i * 4 - 3) = i & "月"
     
107.         .Offset(, i * 4 - 3).Resize(, 4).HorizontalAlignment = xlCenterAcrossSelection
     
108.         .Offset(1, (i - 1) * 3 + i).Resize(, UBound(arr3) + 1) = arr3
     
109.         .Offset(1, (i - 1) * 3 + i + 3) = "小计"
     
110.     Next
     
111.         .Offset(0) = "省份"
     
112.         .Offset(1, (UBound(arr3) + 2) * m + 1) = "总计"                               '"品种"最后一个偏移位置写上"总计"
     
113.         .Offset(2).Resize(UBound(arr2) + 1) = Application.Transpose(arr2)             '写"地区"
     
114.         .Offset(2, 1).Resize(UBound(arr2) + 1, (UBound(arr3) + 2) * m + 1) = crr      '输出数据
     
115.         .Offset(, (UBound(arr3) + 2) * m + 1).Resize(2, 1).Merge
     
116.         .Resize(2, 1).Merge
     
117.         .CurrentRegion.Select
     
118.     End With
     
119.     With Selection.Borders                                               '画表格线
     
120.         .LineStyle = xlContinuous
     
121.         .Weight = xlThin
     
122.         .ColorIndex = xlAutomatic
     
123.    
     
124.     End With
     
125.     Cells.EntireColumn.AutoFit
     
126.     [r19].Select
     
127.    
     
128.     MsgBox "作业二完成!" & Chr(13) & Chr(13) & "结果可与透视表二对照", , "友情提示"
     
129.    
     
130.         
     
131.    
     
132. End Sub
     
133. 
     
134. Sub 自动登录论坛()
     
135. 
     
136.     Dim ie As Object, tt&, i&, k%
     
137.     Set ie = CreateObject("internetexplorer.application")
     
138.     On Error Resume Next
     
139.    
     
140.     With ie
     
141.         For k = 1 To 3
     
142.         .Navigate "http://www.excelpx.com/forum-99-1.html"
     
143.         .Visible = True   '显示网页
     
144.         Do Until ie.ReadyState = 4
     
145.             DoEvents     '在窗体加载时转交操作权
     
146.         Loop
     
147.         If InStr(.document.all.tags("td")(0).innerText, "用户名") Then     '检测是否登录状态
     
148.             .document.Forms(0).all("username").Value = "论坛ID"           '填写论坛登录用户名
     
149.             .document.Forms(0).all("password").Value = "登录密码"          '填写论坛登录密码
     
150.             .document.Forms(0).submit
     
151.         End If
     
152.          tt = Timer
     
153.                 Do Until Timer > tt + 1                                    '延迟1秒
     
154.                
     
155.                     DoEvents
     
156.                 Loop
     
157.     Do Until .document.all.tags("td")(0).innerText = ""
     
158.         DoEvents
     
159.     Loop
     
160.     If InStr(.document.all("um").innerText, "论坛ID") Then                     '填写论坛ID,再次检测登录成功则发帖
     
161.             .document.all("subject").Value = Sheets("作业三").Cells(k + 1, 1)   '标题
     
162.             .document.all("message").Value = Sheets("作业三").Cells(k + 1, 2)   '内容
     
163.             .document.getElementById("typeid_fast").Value = 242                 '类别
     
164.             .document.Forms(2).submit
     
165.             tt = Timer
     
166.                 Do Until Timer > tt + 1                                         '延迟1秒
     
167.                
     
168.                     DoEvents
     
169.                 Loop
     
170.                                                                         
     
171.                  Do Until Timer > tt + 15                                       '第二次发帖需间隔15秒
     
172.                     DoEvents
     
173.                 Loop
     
174.         
     
175.    
     
176.     End If
     
177.     Next k
     
178.    .Quit                                                                                '关闭打开的网页
     
179.     End With
     
180.    
     
181.     Set ie = Nothing
     
182.    
     
183. End Sub

复制代码

hrpotter

C03:hrpotter

1. Option Explicit
   
2. Sub 作业一()
   
3.     Dim arr, brr, d1, d2
   
4.     Dim i As Long
   
5.     Set d1 = CreateObject("scripting.dictionary")
   
6.     Set d2 = CreateObject("scripting.dictionary")
   
7.     arr = Range("a1").CurrentRegion
   
8.     For i = 2 To UBound(arr)
   
9.         If Not d1.exists(arr(i, 1)) Then d1(arr(i, 1)) = d1.Count + 1    '将地区加入字典，作为行标题
   
10.         If Not d2.exists(arr(i, 2)) Then d2(arr(i, 2)) = d2.Count + 1    '将品种加入字典，作为列标题
    
11.     Next
    
12.     ReDim brr(1 To d1.Count, 1 To d2.Count)    '定义汇总数据的结果数组
    
13.     For i = 2 To UBound(arr)
    
14.         brr(d1(arr(i, 1)), d2(arr(i, 2))) = brr(d1(arr(i, 1)), d2(arr(i, 2))) + arr(i, 3)
    
15.         '用字典取出行列位置，并进行累加
    
16.     Next
    
17.     Range("f2").Resize(d1.Count) = Application.Transpose(d1.keys)    '写入行标题
    
18.     Range("g1").Resize(1, d2.Count) = d2.keys    '写入列标题
    
19.     Range("g2").Resize(UBound(brr), UBound(brr, 2)) = brr    '写入汇总的结果数组
    
20. End Sub
    
21. Sub 作业二()
    
22.     Dim arr, brr(1 To 10000, 1 To 49) As Long, d1, d2
    
23.     Dim i As Long, j As Long, k As Long, l As Long
    
24.     Set d1 = CreateObject("scripting.dictionary")
    
25.     Set d2 = CreateObject("scripting.dictionary")
    
26.     arr = Range("a1").CurrentRegion
    
27.     d2("草莓") = 1
    
28.     d2("苹果") = 2
    
29.     d2("葡萄") = 3  '将列标题品种加入字典
    
30.     For i = 2 To UBound(arr)
    
31.         If Not d1.exists(arr(i, 2)) Then
    
32.             d1(arr(i, 2)) = d1.Count + 1    '将地区加入字典，item为行位置
    
33.         End If
    
34.         j = d1(arr(i, 2))    '取出行位置
    
35.         k = (Month(arr(i, 1)) - 1) * 4 + d2(arr(i, 3))    '计算出列位置
    
36.         l = Month(arr(i, 1)) * 4    '计算出小计的列位置
    
37.         brr(j, k) = brr(j, k) + arr(i, 4)    '汇总累加
    
38.         brr(j, l) = brr(j, l) + arr(i, 4)    '小计累加
    
39.         brr(j, 49) = brr(j, 49) + arr(i, 4)  '合计累加
    
40.     Next
    
41.     Range("f3").Resize(10000, 50).ClearContents    '清空数据区域
    
42.     Range("f3").Resize(d1.Count) = Application.Transpose(d1.keys)    '写入行标题
    
43.     Range("g3").Resize(d1.Count, 49) = brr    '写入汇总数据
    
44. End Sub
    
45. Sub 作业二附加()
    
46.     Dim arr, brr, crr, d1, d2
    
47.     Dim i As Long, j As Long, k As Long, l As Long
    
48.     Set d1 = CreateObject("scripting.dictionary")
    
49.     Set d2 = CreateObject("scripting.dictionary")
    
50.     arr = Range("a1").CurrentRegion
    
51.     For i = 2 To UBound(arr)
    
52.         If Not d1.exists(arr(i, 2)) Then d1(arr(i, 2)) = d1.Count + 1    '将地区加入字典，作为行标题
    
53.         If Not d2.exists(arr(i, 3)) Then d2(arr(i, 3)) = d2.Count + 1    '将品种加入字典，作为列标题
    
54.     Next
    
55.     ReDim brr(1 To 2, 1 To d2.Count * 12 + 14)
    
56.     brr(1, 1) = "省份"
    
57.     brr(1, UBound(brr, 2)) = "合计"
    
58.     crr = d2.keys
    
59.     For i = 1 To 12
    
60.         For j = 1 To d2.Count
    
61.             k = (i - 1) * (d2.Count + 1) + j
    
62.             brr(2, k + 1) = crr(j - 1)
    
63.         Next
    
64.         brr(1, (i - 1) * (d2.Count + 1) + 2) = i & "月"
    
65.         brr(2, i * (d2.Count + 1) + 1) = "小计"             '设置标题
    
66.     Next
    
67.     ReDim crr(1 To d1.Count, 1 To UBound(brr, 2) - 1) As Long
    
68.     For i = 2 To UBound(arr)
    
69.         j = d1(arr(i, 2))    '取出行位置
    
70.         k = (Month(arr(i, 1)) - 1) * (d2.Count + 1) + d2(arr(i, 3))  '计算出列位置
    
71.         l = Month(arr(i, 1)) * (d2.Count + 1)    '计算出小计的列位置
    
72.         crr(j, k) = crr(j, k) + arr(i, 4)    '汇总累加
    
73.         crr(j, l) = crr(j, l) + arr(i, 4)    '小计累加
    
74.         crr(j, UBound(crr, 2)) = crr(j, UBound(crr, 2)) + arr(i, 4)    '合计累加
    
75.     Next
    
76.     With Range("f1")
    
77.         .Resize(50, 100).Clear
    
78.         .Resize(2, UBound(brr, 2)) = brr    '写入列标题
    
79.         .Offset(2).Resize(d1.Count) = Application.Transpose(d1.keys)    '写入行标题
    
80.         .Offset(2, 1).Resize(UBound(crr), UBound(crr, 2)) = crr    '写入汇总数据区域
    
81.         .Resize(2, 1).MergeCells = True    '以下设置汇总表格式
    
82.         .Offset(, UBound(crr, 2)).Resize(2, 1).MergeCells = True
    
83.         For i = 1 To 12
    
84.             .Offset(, (d2.Count + 1) * (i - 1) + 1).Resize(, d2.Count + 1).MergeCells = True
    
85.         Next
    
86.         With .Resize(2, UBound(brr, 2))
    
87.             .HorizontalAlignment = xlCenter
    
88.             .VerticalAlignment = xlCenter
    
89.         End With
    
90.         With .Resize(d1.Count + 2)
    
91.             .HorizontalAlignment = xlCenter
    
92.             .VerticalAlignment = xlCenter
    
93.         End With
    
94.         .Resize(d1.Count + 2, UBound(brr, 2)).Borders.LineStyle = xlContinuous
    
95.     End With
    
96. End Sub
    
97. Sub 作业三()
    
98.     Dim arr
    
99.     Dim i As Long, t
    
100.     Dim ie As New InternetExplorer    '创建一个IE对象
     
101.     arr = Range("a1").CurrentRegion
     
102.     For i = 2 To UBound(arr)
     
103.         With ie
     
104.             .Navigate "http://www.excelpx.com/forum.php?mod=post&action=newthread&fid=99"  'Navigate方法可以打开指定的网页
     
105.             .Visible = True    '打开后要显示网页
     
106.             Do Until ie.ReadyState = READYSTATE_COMPLETE    '如果IE加载宏完成
     
107.                 DoEvents    '在窗体加载时转交操作权
     
108.             Loop
     
109.             .Document.all("typeid").Value = "242"    '主题分类选择文字
     
110.             .Document.all("subject").Value = arr(i, 1)    '标题
     
111.             .Document.all("message").Value = arr(i, 2)    '内容
     
112.             .Document.all("topicsubmit").Click    '提交
     
113.             t = Timer
     
114.             Do While Timer < t + 20    '设定20秒的间隔
     
115.                 DoEvents
     
116.             Loop
     
117.             .Quit '关闭网页
     
118.         End With
     
119.         Set ie = Nothing
     
120.     Next
     
121. End Sub

复制代码

箫风

1. 
   
2. Option Explicit
   
3. Sub 作业一()
   
4.     Dim i As Long, j As Long, s As String
   
5.     Dim Arr, Arr1, Arr2()
   
6.     Dim d1 As New Dictionary, d2 As New Dictionary, d3 As New Dictionary
   
7.     Range("G1", Cells(1, Columns.Count).End(2)).ClearContents
   
8.     Range("F2:L" & Cells(Rows.Count, 1).End(3).Row).ClearContents
   
9.     Arr = Range("A2:C" & Cells(Rows.Count, 1).End(3).Row).Value
   
10.     '分别生成不重复地区和品种，并对不重复的地区品种的数量进行统计
    
11.     For i = LBound(Arr) To UBound(Arr)
    
12.         If Not d1.Exists(Arr(i, 1)) Then d1.Add Arr(i, 1), ""
    
13.         If Not d2.Exists(Arr(i, 2)) Then d2.Add Arr(i, 2), ""
    
14.         s = Arr(i, 1) & "#" & Arr(i, 2)
    
15.         d3(s) = d3(s) + Arr(i, 3)
    
16.     Next
    
17.     Arr1 = d1.Keys
    
18.     '调整数组大小存放汇总结果
    
19.     ReDim Arr2(1 To d1.Count, 1 To d2.Count + 1)
    
20.     '    行循环
    
21.     For i = 1 To d1.Count
    
22.         Arr2(i, 1) = Arr1(i - 1)    'D1.keys(i-1)
    
23.         For j = 2 To d2.Count + 1
    
24.             '数组的第2到最后列，第1列为地区
    
25.             s = Arr1(i - 1) & "#" & d2.Keys(j - 2)  '地区#品种
    
26.             If d3.Exists(s) Then Arr2(i, j) = d3(s)
    
27.         Next j
    
28.     Next i
    
29.     Range("G1").Resize(, d2.Count) = d2.Keys
    
30.     Range("F2").Resize(i - 1, j - 1).Value = Arr2
    
31. End Sub
    
32. 
    
33. 
    
34. Sub 作业二()
    
35.     Dim i As Long, j As Long, str As String
    
36.     Dim xj As Long, hj As Long
    
37.     Dim m As Byte, n As Byte, p As Byte
    
38.     Dim Arr, Arr1, Arr2()
    
39.     Dim d1 As New Dictionary
    
40.     Dim d2 As New Dictionary
    
41.     Dim d3 As New Dictionary
    
42.     Application.ScreenUpdating = False
    
43.    
    
44.     Arr = Range("A1").CurrentRegion.Value
    
45.     For i = 2 To UBound(Arr)
    
46.         If Not d1.Exists(Arr(i, 2)) Then d1.Add Arr(i, 2), ""
    
47.         If Not d2.Exists(Arr(i, 3)) Then d2.Add Arr(i, 3), ""
    
48.         str = Format(Arr(i, 1), "m月") & Arr(i, 2) & Arr(i, 3)
    
49.         d3(str) = d3(str) + Arr(i, 4)
    
50.     Next i
    
51.     '删除并生成新的月份和品种的标题,清空原有数据
    
52.     m = d2.Count
    
53.     Range(Cells(1, 7), Cells(2, 7 + (m + 1) * 12)).UnMerge
    
54.     Range(Cells(1, 7), Cells(2, 7 + (m + 1) * 12)).ClearContents
    
55.     Range(Cells(3, 6), Cells(Rows.Count, 7 + (m + 1) * 12)).ClearContents
    
56.     For i = 1 To 12
    
57.         With Cells(1, 7 + (m + 1) * (i - 1)).Resize(, m + 1)
    
58.             .Merge
    
59.             .HorizontalAlignment = xlCenter
    
60.             .VerticalAlignment = xlCenter
    
61.             .Value = i & "月"
    
62.         End With
    
63.         Cells(2, 7 + (m + 1) * (i - 1)).Resize(, m) = d2.Keys
    
64.         Cells(2, 10 + (m + 1) * (i - 1)) = "小计"
    
65.     Next i
    
66.     With Range(Cells(1, 7 + (m + 1) * 12), Cells(2, 7 + (m + 1) * 12))
    
67.         .Merge
    
68.         .HorizontalAlignment = xlCenter
    
69.         .VerticalAlignment = xlCenter
    
70.         .Value = "合计"
    
71.     End With
    
72.    
    
73.     Arr1 = d1.Keys
    
74.     '调整数组大小存放汇总结果
    
75.     ReDim Arr2(1 To d1.Count, 1 To (m + 1) * 12 + 2)
    
76.     '行循环
    
77.     For i = 1 To d1.Count
    
78.         Arr2(i, 1) = Arr1(i - 1)    'D1.keys(i-1)
    
79.         For j = 2 To (m + 1) * 12 + 2
    
80.             '数组的第2到最后列，第1列为地区
    
81.             p = (j - 1) Mod (m + 1)
    
82.             If p <> 0 Then
    
83.                 n = (j - 1) \ (m + 1) + 1
    
84.                 str = n & "月" & Arr1(i - 1) & d2.Keys(p - 1) '月份地区品种
    
85.                 If d3.Exists(str) Then Arr2(i, j) = d3(str)
    
86.                 xj = xj + Arr2(i, j)
    
87.             Else
    
88.                 Arr2(i, j) = xj
    
89.                 hj = hj + xj
    
90.                 xj = 0
    
91.             End If
    
92.         Next j
    
93.         Arr2(i, j - 1) = hj
    
94.         hj = 0
    
95.     Next i
    
96.     Range("F3").Resize(i - 1, j - 1).Value = Arr2
    
97.     Application.ScreenUpdating = True
    
98. End Sub
    

复制代码

cxloen

1. Sub 作业1()
   
2. 
   
3. Dim arr1, arr2(1 To 1000, 1 To 10)
   
4. Dim d1 As New Dictionary
   
5. Dim d2 As New Dictionary
   
6. Dim d3 As New Dictionary
   
7. Dim i%, j%, k%
   
8.     arr1 = Range("a1").CurrentRegion    '将数据区域赋值给数组
   
9.     For i = 2 To UBound(arr1)           '循环数组
   
10.         If d1.Exists(arr1(i, 1)) = 0 Then   '如有新出现的地区标识赋值给字典
    
11.             j = j + 1
    
12.             d1(arr1(i, 1)) = j      '记录地区的行号
    
13.         End If
    
14.         If d2.Exists(arr1(i, 2)) = 0 Then   '如有新出现的品种赋值给字典
    
15.             k = k + 1
    
16.             d2(arr1(i, 2)) = k      '记录品种出现的列号
    
17.         End If
    
18.         
    
19.         arr2(d1(arr1(i, 1)), d2(arr1(i, 2))) = arr2(d1(arr1(i, 1)), d2(arr1(i, 2))) + arr1(i, 3)    '统计地区及品种标识下的销量
    
20.     Next
    
21.    
    
22.         Range("f2").Resize(d1.Count, 1) = Application.Transpose(d1.Keys)    '输出数据
    
23.         Range("g1").Resize(1, d2.Count) = d2.Keys
    
24.         Range("g2").Resize(d1.Count, d2.Count) = arr2
    
25.    
    
26.    
    
27. End Sub
    
28. 
    
29. 
    
30. Sub 作业2()
    
31. Dim arr, arr1(1 To 100, 1 To 49)
    
32. Dim i%, k%, n%, j%, m%
    
33. Dim d1 As New Dictionary
    
34. Dim d2 As New Dictionary    '省
    
35. Dim d3 As New Dictionary    '产品
    
36. arr = Range("a1").CurrentRegion     '获取表格数据
    
37. For i = 2 To UBound(arr)    '从表格第二行开始循环
    
38. '以地区+品种+销售月份 汇总销售数量
    
39.     d1(arr(i, 2) & arr(i, 3) & Month(arr(i, 1)) & "月") = d1(arr(i, 2) & arr(i, 3) & Month(arr(i, 1)) & "月") + arr(i, 4)
    
40.     If d2.Exists(arr(i, 2)) = 0 Then    '获取唯一地区标识给字典D2
    
41.         k = k + 1   '生成数组的行号
    
42.         d2(arr(i, 2)) = k
    
43.     End If
    
44.     If d3.Exists(arr(i, 3)) = 0 Then d3(arr(i, 3)) = ""     '获取品种唯一值给字典D3
    
45.    
    
46.     Next
    
47. 
    
48.     For j = 0 To d2.Count - 1   '按地区及月份嵌套循环赋值给数组ARR1
    
49.     For i = 1 To 12
    
50.         On Error Resume Next    '如果超过字典下标退出循环，月份为12个月，数据区域只有11月
    
51.         
    
52.         arr1(j + 1, (i - 1) * 4 + 1) = d1(d2.Keys(j) & d3.Keys(1) & i & "月")   '将草莓销售量赋值给数组
    
53.         arr1(j + 1, (i - 1) * 4 + 2) = d1(d2.Keys(j) & d3.Keys(2) & i & "月")   ''将苹果销售量赋值给数组
    
54.         arr1(j + 1, (i - 1) * 4 + 3) = d1(d2.Keys(j) & d3.Keys(0) & i & "月")      '将葡萄销售量赋值给数组
    
55.         n = arr1(j + 1, (i - 1) * 4 + 1) + arr1(j + 1, (i - 1) * 4 + 2) + arr1(j + 1, (i - 1) * 4 + 3)  '统计三个品种销售量给变量
    
56.         If n <> 0 Then arr1(j + 1, (i - 1) * 4 + 4) = n         '如果销量小计不等于0则将销售量赋值给小计列
    
57.         m = m + arr1(j + 1, (i - 1) * 4 + 4)        '统计第月的小计和
    
58.     Next
    
59.         If m <> 0 Then arr1(j + 1, 49) = m          '将12个月的小计和赋值给总计所在的数组位置
    
60.         m = 0           '总计归0
    
61.     Next
    
62.    
    
63. 
    
64. 
    
65.     Range("f3").Resize(d2.Count, 1) = Application.Transpose(d2.Keys)    '输出各地区列表
    
66.     Range("g3").Resize(d2.Count, 49) = arr1             '输出统计销售量
    
67. 
    
68. 
    
69. 
    
70. End Sub

复制代码

Sellby

只做了二个，先交了吧

1. Option Explicit
   
2. 
   
3. Sub 作业1()
   
4.     Dim arr, brr
   
5.     Dim d1 As New Dictionary, d2 As New Dictionary
   
6.     Dim i%
   
7.     With Sheets("作业一")
   
8.         arr = .Range("a1").CurrentRegion.Value
   
9.          '定义一个数组，用来放统计的结果
   
10.         ReDim brr(1 To 40, 1 To 20)
    
11.         For i = 2 To UBound(arr)
    
12.             'd1字典用来放地区，确定地区的位置
    
13.             'd2字典用来放品种，确定品种的位置
    
14.             If Not d1.exists(arr(i, 1)) Then d1(arr(i, 1)) = d1.Count + 1
    
15.             If Not d2.exists(arr(i, 2)) Then d2(arr(i, 2)) = d2.Count + 1
    
16.             '通过二个字典获得数组的标号，进行统计
    
17.             brr(d1(arr(i, 1)), d2(arr(i, 2))) = brr(d1(arr(i, 1)), d2(arr(i, 2))) + arr(i, 3)
    
18.         Next i
    
19.         '将统计结果写入指定单元格
    
20.         .Range("f2:f6000").ClearContents
    
21.         .Range("g:l").ClearContents
    
22.         .Range("f2").Resize(d1.Count) = Application.Transpose(d1.Keys)
    
23.         .Range("g1").Resize(1, d2.Count) = d2.Keys
    
24.         .Range("g2").Resize(d1.Count, d2.Count) = brr
    
25.     End With
    
26.     '===释放对象
    
27.     Set d1 = Nothing
    
28.     Set d2 = Nothing
    
29.     MsgBox "数据整理完成!", vbInformation + vbOKOnly
    
30. End Sub
    
31. 
    
32. 
    
33. Sub 作业2通用()
    
34.     Dim arr, brr
    
35.     Dim d1 As New Dictionary, d2 As New Dictionary
    
36.     Dim i%, j%, x%, y%, m As Byte
    
37.     With Sheets("作业二")
    
38.         arr = .Range("a1").CurrentRegion.Value
    
39.         
    
40.          '＝＝＝第一次循环，建立二个字典
    
41.         For i = 2 To UBound(arr)
    
42.             'd1字典用来放地区，确定地区的位置
    
43.             'd2字典用来放品种，确定品种的位置
    
44.             If Not d1.exists(arr(i, 2)) Then d1(arr(i, 2)) = d1.Count + 1
    
45.             If Not d2.exists(arr(i, 3)) Then d2(arr(i, 3)) = d2.Count + 1
    
46.         Next i
    
47.         '===
    
48.         
    
49.          '定义一个数组，用来放统计的结果。行数是省份数量，列数是（品种数+小计）*12个月+合计
    
50.         ReDim brr(-1 To d1.Count, 1 To (d2.Count + 1) * 12 + 1)
    
51.         
    
52.         '===
    
53.         '确定表头的内容
    
54.         For i = 1 To UBound(brr, 2) - 1 Step d2.Count + 1
    
55.             brr(-1, i) = (i \ (d2.Count + 1) + 1) & "月"
    
56.             For j = 0 To d2.Count - 1
    
57.                 brr(0, i + j) = d2.Keys(j)
    
58.             Next j
    
59.             brr(0, i + d2.Count) = "小计"
    
60.         Next i
    
61.         brr(0, (d2.Count + 1) * 12 + 1) = "合计"
    
62.         '===
    
63.         
    
64.         '===第二次循环，进行数据统计
    
65.         For i = 2 To UBound(arr)
    
66.             m = Month(arr(i, 1)) '月份
    
67.             x = d1(arr(i, 2)) '省份的位置，即数组的行标
    
68.             y = d2(arr(i, 3)) + (d2.Count + 1) * (m - 1) '每月品种的位置，即数组的列标
    
69.             brr(x, y) = brr(x, y) + arr(i, 4) '各月各品种统计
    
70.             brr(x, m * (d2.Count + 1)) = brr(x, m * (d2.Count + 1)) + arr(i, 4) '各月的小计
    
71.             brr(x, (d2.Count + 1) * 12 + 1) = brr(x, (d2.Count + 1) * 12 + 1) + arr(i, 4) '合计
    
72.         Next i
    
73.         '===
    
74.         
    
75.         '===在指定单元格写入数据及设置格式
    
76.         .Range("f:fz").Clear
    
77.         .Range("f1") = "省份"
    
78.         .Range("f3").Resize(d1.Count) = Application.Transpose(d1.Keys)
    
79.         .Range("g1").Resize(UBound(brr) - LBound(brr) + 1, UBound(brr, 2)) = brr
    
80.          
    
81.          '===设置格式
    
82.         .Range("f1:f2").Merge
    
83.         For i = 7 To 7 + UBound(brr, 2) - 2 Step d2.Count + 1
    
84.             .Cells(1, i).Resize(1, d2.Count + 1).Merge
    
85.         Next i
    
86.         .Range("f1").Offset(, UBound(brr, 2)).Resize(2).Merge
    
87.         With .Range("f1").Resize(UBound(brr) - LBound(brr) + 1, UBound(brr, 2) + 1)
    
88.             .Borders.LineStyle = xlContinuous
    
89.             .HorizontalAlignment = xlCenter
    
90.             .VerticalAlignment = xlCenter
    
91.         End With
    
92.     End With
    
93.     '===释放对象
    
94.     Set d1 = Nothing
    
95.     Set d2 = Nothing
    
96.     MsgBox "数据整理完成!", vbInformation + vbOKOnly
    
97. End Sub

复制代码

xdragon

C08:xdragon

1. Sub 作业一()
   
2. 
   
3.   Dim arr, brr(), crr(), drr(), d1 As Object, d2 As Object, i&, cnt1&, cnt2 As Byte
   
4.   arr = Range("A2:C" & Cells(Rows.Count, 1).End(3).Row).Value
   
5.   Set d1 = CreateObject("scripting.dictionary")
   
6.   Set d2 = CreateObject("scripting.dictionary")
   
7.   ReDim brr(1 To UBound(arr), 1 To 1) '设置一个足够行数的数组
   
8.   
   
9.   For i = 1 To UBound(arr)
   
10.     If Not d1.exists(arr(i, 1)) Then '如果地区不存在则添加入字典d1
    
11.       cnt1 = cnt1 + 1
    
12.       ReDim Preserve crr(1 To cnt1 + 1)
    
13.       d1(arr(i, 1)) = cnt1
    
14.     End If
    
15.     If Not d2.exists(arr(i, 2)) Then '如果品种不存在则添加入字典d2
    
16.       cnt2 = cnt2 + 1
    
17.       ReDim Preserve brr(1 To UBound(arr), 1 To cnt2)
    
18.       ReDim Preserve drr(1 To cnt2 + 1)
    
19.       d2(arr(i, 2)) = cnt2
    
20.     End If
    
21.     brr(d1(arr(i, 1)), d2(arr(i, 2))) = brr(d1(arr(i, 1)), d2(arr(i, 2))) + arr(i, 3) '对相同地区、品种的数量进行累计
    
22.     crr(d1(arr(i, 1)) + 1) = crr(d1(arr(i, 1)) + 1) + arr(i, 3) '行合计
    
23.     drr(d2(arr(i, 2)) + 1) = drr(d2(arr(i, 2)) + 1) + arr(i, 3) '列合计
    
24.   Next
    
25.   crr(1) = "合计": drr(1) = "合计"
    
26.   
    
27.   Dim rng As Range '导出区域设置，导出相关数据
    
28.   Set rng = Range("F1")
    
29.   With rng
    
30.     .CurrentRegion.ClearContents
    
31.     .Value = "    品种" & Chr(10) & "地区"
    
32.     .Offset(1, 0).Resize(cnt1) = Application.Transpose(d1.keys) '地区
    
33.     .Offset(0, 1).Resize(1, cnt2) = d2.keys '品种
    
34.     .Offset(1, 1).Resize(cnt1, cnt2) = brr '数量
    
35.     .Offset(cnt1 + 1).Resize(1, cnt2 + 1) = drr '列合计
    
36.     .Offset(0, cnt2 + 1).Resize(cnt1 + 1, 1) = Application.Transpose(crr) '行合计
    
37.     .Offset(cnt1 + 1, cnt2 + 1) = Application.Sum(rng.Offset(cnt1 + 1, 1).Resize(1, cnt2)) '总计
    
38.   End With
    
39.   
    
40. End Sub
    
41. 
    
42. Sub 作业二()
    
43.   Dim arr, brr(), crr()
    
44.   Dim i As Integer, tmp
    
45.   Dim cnt2 As Integer, cnt3 As Integer, str As String
    
46.   Dim d2 As Object, d3 As Object
    
47.   Dim rng As Range
    
48.   '数据源导入数组中
    
49.   arr = Range("A2:D" & Cells(Rows.Count, 1).End(3).Row).Value
    
50.   
    
51.   Set d2 = CreateObject("scripting.dictionary")
    
52.   Set d3 = CreateObject("scripting.dictionary")
    
53.   
    
54.   crr = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
    
55.   For i = 1 To UBound(arr)
    
56.     '统计行高
    
57.     If Not d2.exists(arr(i, 2)) Then cnt2 = cnt2 + 1: d2(arr(i, 2)) = cnt2
    
58.     '统计品种不同的数量
    
59.     If Not d3.exists(arr(i, 3)) Then cnt3 = cnt3 + 1: d3(arr(i, 3)) = cnt3
    
60.   Next
    
61.   '根据d1,d2,d3设置导出数组大小
    
62.   ReDim brr(1 To d2.Count, 1 To (d3.Count + 1) * 12 + 1)
    
63.   
    
64.   For i = 1 To UBound(arr)
    
65.     tmp = (crr(Month(arr(i, 1)) - 1) - 1) * (d3.Count + 1) + d3(arr(i, 3))
    
66.     brr(d2(arr(i, 2)), tmp) = brr(d2(arr(i, 2)), tmp) + arr(i, 4) '累计各月各品种产品各地区的数量
    
67.     tmp = (tmp \ (d3.Count + 1) + 1) * (d3.Count + 1)
    
68.     brr(d2(arr(i, 2)), tmp) = brr(d2(arr(i, 2)), tmp) + arr(i, 4) '计算各月小计
    
69.     brr(d2(arr(i, 2)), UBound(brr, 2)) = brr(d2(arr(i, 2)), UBound(brr, 2)) + arr(i, 4) '计算各月总计
    
70.   Next
    
71.   
    
72.   Erase arr
    
73.   ReDim arr(1 To 2, 1 To UBound(brr, 2))
    
74.   tmp = d3.keys
    
75.   '设置第一行与第二行列标签
    
76. 
    
77.   For i = 1 To UBound(arr, 2) - 1
    
78.     If i Mod (UBound(tmp) + 2) = 1 Then arr(1, i) = crr(i \ (UBound(tmp) + 2)) & "月"
    
79.     If i Mod (UBound(tmp) + 2) = 0 Then
    
80.       arr(2, i) = "小计"
    
81.     Else
    
82.       arr(2, i) = tmp(i Mod (UBound(tmp) + 2) - 1)
    
83.     End If
    
84.   Next
    
85.   arr(1, UBound(arr, 2)) = "合计"
    
86.   Erase tmp
    
87.   '设置结果导出区域,导出各处理结果
    
88.   Set rng = [f1]
    
89.   With rng
    
90.     .CurrentRegion.UnMerge
    
91.     .CurrentRegion.Clear
    
92.     .Value = "省份"
    
93.     .Offset(2, 0).Resize(d2.Count) = Application.Transpose(d2.keys)
    
94.     .Offset(0, 1).Resize(2, UBound(arr, 2)) = arr
    
95.     .Offset(2, 1).Resize(d2.Count, UBound(brr, 2)) = brr
    
96.     .Resize(2 + d2.Count, 1 + UBound(brr, 2)).Borders.LineStyle = 1
    
97.     '设置标题行与标题列的背景颜色
    
98.     .Resize(2 + d2.Count).Interior.ThemeColor = xlThemeColorAccent6
    
99.     .Resize(2, 1 + UBound(brr, 2)).Interior.ThemeColor = xlThemeColorAccent6
    
100.     '合并单元格设置
     
101.     For i = 1 To UBound(arr, 2) - 1 Step d3.Count + 1
     
102.        .Offset(0, i).Resize(1, d3.Count + 1).Merge
     
103.        .Offset(0, i).Resize(1, d3.Count + 1).HorizontalAlignment = xlCenter
     
104.     Next
     
105.     .Resize(2).Merge
     
106.     .Offset(0, UBound(arr, 2)).Resize(2).Merge
     
107.   End With
     
108.   
     
109.   d2.RemoveAll
     
110.   d3.RemoveAll
     
111.   
     
112. End Sub
     
113. 
     
114. Sub 作业三()
     
115.     Dim username As String, password As String, i As Integer
     
116.    
     
117.     With CreateObject("internetexplorer.application")
     
118.         .Visible = False
     
119.         .navigate "http://www.excelpx.com/forum-99-1.html"
     
120.         
     
121.         Do Until .readystate = 4
     
122.           DoEvents
     
123.         Loop
     
124.         
     
125.         On Error Resume Next
     
126.         username = InputBox("请输入登录用户名（若为自动登录请点击取消）", "提示")
     
127.         If username = "" Then GoTo messagesend
     
128.         password = InputBox("请输入登录密码", "提示")
     
129.         With .document.forms(0)
     
130.           .all("username").Value = username
     
131.           .all("password").Value = password
     
132.           .submit
     
133.         End With
     
134.         Do Until .readystate = 4
     
135.           DoEvents
     
136.         Loop
     
137.         
     
138. messagesend:
     
139.         For i = 2 To Cells(Rows.Count, 1).End(3).Row
     
140.            message i
     
141.         Next
     
142.     End With
     
143.    
     
144. End Sub
     
145. 
     
146. Sub message(i As Integer)
     
147.     With CreateObject("internetexplorer.application")
     
148.         .Visible = False
     
149.         .navigate "http://www.excelpx.com/forum-99-1.html"
     
150.         Do Until .readystate = 4
     
151.           DoEvents
     
152.         Loop
     
153.         With .document
     
154.             .getelementbyid("typeid_fast").Click
     
155.             .all.tags("li")(1).Click
     
156.             .forms(2).all("subject").Value = Cells(i, 1)
     
157.             .forms(2).all("message").Value = Cells(i, 2)
     
158.             .forms(2).submit
     
159.         End With
     
160.         Do Until .readystate = 4
     
161.           DoEvents
     
162.         Loop
     
163.         .Quit
     
164.         If i = Cells(Rows.Count, 1).End(3).Row Then Exit Sub
     
165.     End With
     
166.     Application.Wait Now + TimeValue("00:00:25")
     
167. End Sub

复制代码

作业三时间仓促，没有最终测试了。。。万一死机了，见谅啊。。。。。

sayloveyou2010

C01：sayloveyou2010（小妮子）

1. 
   
2. Sub 作业一()
   
3.     Dim dic As New Dictionary, dic1 As New Dictionary, arr(), brr(), x% '定义相关变量
   
4.     arr = Range("A1").CurrentRegion.Offset(1).Value '把数据源装入数组arr
   
5.     ReDim brr(1 To UBound(arr), 1 To UBound(arr)) '重新定义结果数组brr
   
6.     For x = 1 To UBound(arr) '循环arr一维
   
7.         If Not dic.Exists(arr(x, 1)) Then '判断地区是否存在
   
8.             dic(arr(x, 1)) = dic.Count + 1 '不存在创建字典，并记录item值
   
9.         End If
   
10.         If Not dic1.Exists(arr(x, 2)) Then '判断品种是否存在
    
11.             dic1(arr(x, 2)) = dic1.Count + 1 '不存在创建字典，并记录item值
    
12.         End If
    
13.         brr(dic(arr(x, 1)), dic1(arr(x, 2))) = brr(dic(arr(x, 1)), dic1(arr(x, 2))) + arr(x, 3) '累加数量
    
14.     Next x
    
15.     [F2].Resize(dic.Count, 1) = Application.Transpose(dic.Keys) '读出地区
    
16.     [G1].Resize(1, dic1.Count) = dic1.Keys '读出品种
    
17.     [G2].Resize(dic.Count - 1, dic1.Count - 1) = brr '读出数量
    
18.     Set dic = Nothing: Set dic1 = Nothing
    
19.     Erase arr, brr
    
20. End Sub
    
21. Sub 作业二()
    
22.     Dim dic As New Dictionary, dic1 As New Dictionary, arr(), brr(), x%, MyD$ '定义相关变量
    
23.     arr = Range("A1").CurrentRegion.Offset(1).Value '把区域装入数组
    
24.     ReDim brr(1 To UBound(arr), 1 To UBound(arr)) '重新定义结果数组
    
25.     For x = 1 To UBound(arr) '循环数据源数组一维
    
26.         If Not dic.Exists(arr(x, 2)) Then '判断不存在
    
27.             dic(arr(x, 2)) = dic.Count + 1 '创建字典，并记录item
    
28.         End If
    
29.     Next x
    
30.     For x = 1 To 12
    
31.         dic1(x & "月" & vbTab & "草莓") = dic1.Count + 1 '创建水果字典，并记录item
    
32.         dic1(x & "月" & vbTab & "苹果") = dic1.Count + 1
    
33.         dic1(x & "月" & vbTab & "葡萄") = dic1.Count + 1
    
34.         dic1(x & "月" & vbTab & "小计") = dic1.Count + 1
    
35.     Next x
    
36.     dic1("合计") = 1
    
37.     For x = 1 To UBound(arr) - 1 '循环Arr一维
    
38.         MyD = Month(arr(x, 1)) & "月" & vbTab & arr(x, 3) '联合
    
39.         brr(dic(arr(x, 2)), dic1(MyD)) = brr(dic(arr(x, 2)), dic1(MyD)) + arr(x, 4)   '数量累加
    
40.         brr(dic(arr(x, 2)), dic1(Month(arr(x, 1)) & "月" & vbTab & "小计")) = brr(dic(arr(x, 2)), dic1(Month(arr(x, 1)) & "月" & vbTab & "小计")) + arr(x, 4) '计算小计
    
41.         brr(dic(arr(x, 2)), dic1.Count) = brr(dic(arr(x, 2)), dic1.Count) + arr(x, 4) '计算合计
    
42.     Next x
    
43.     [G3].Resize(dic.Count + 1, dic1.Count) = brr '读出结果数组
    
44.     Set dic = Nothing: Set dic1 = Nothing
    
45.     Erase arr, brr
    
46. End Sub
    
47. Sub 作业二附加题()
    
48.     Dim dic As New Dictionary, dic1 As New Dictionary, dic2 As New Dictionary, arr(), brr(), x%, MyD$, Z% '定义相关变量
    
49.     Application.DisplayAlerts = False
    
50.     Range("F1:ZZ10000").Clear '清除内容
    
51.     arr = Range("A1").CurrentRegion.Offset(1).Value '把区域装入数组
    
52.     ReDim brr(1 To UBound(arr), 1 To UBound(arr)) '重新定义结果数组
    
53.     For x = 1 To UBound(arr)  '循环数据源数组一维
    
54.         If Not dic.Exists(arr(x, 2)) Then '判断不存在
    
55.             dic(arr(x, 2)) = dic.Count + 1 '创建地区字典，并记录item
    
56.         End If
    
57.     Next x
    
58.     For x = 1 To UBound(arr)  '循环数据源数组一维
    
59.         If Not dic.Exists(arr(x, 3)) Then '判断不存在
    
60.             dic2(arr(x, 3)) = dic2.Count + 1 '创建水果字典，并记录item
    
61.         End If
    
62.     Next x
    
63.     For x = 1 To 12
    
64.         For Z = 1 To dic2.Count
    
65.             dic1(x & "月" & vbTab & dic2.Keys(Z - 1)) = dic1.Count + 1 '创建水果字典，并记录item
    
66.         Next Z
    
67.         dic1(x & "月" & vbTab & "小计") = dic1.Count + 1
    
68.     Next x
    
69.     dic1("合计") = 1
    
70.     For x = 1 To UBound(arr) - 1 '循环Arr一维
    
71.         MyD = Month(arr(x, 1)) & "月" & vbTab & arr(x, 3) '联合
    
72.         brr(dic(arr(x, 2)) + 2, dic1(MyD)) = brr(dic(arr(x, 2)) + 2, dic1(MyD)) + arr(x, 4) '数量累加
    
73.         brr(dic(arr(x, 2)) + 2, dic1(Month(arr(x, 1)) & "月" & vbTab & "小计")) = brr(dic(arr(x, 2)) + 2, dic1(Month(arr(x, 1)) & "月" & vbTab & "小计")) + arr(x, 4) '计算小计
    
74.         brr(dic(arr(x, 2)) + 2, dic1.Count) = brr(dic(arr(x, 2)) + 2, dic1.Count) + arr(x, 4) '计算合计
    
75.     Next x
    
76.     [F3].Resize(dic.Count, 1) = Application.Transpose(dic.Keys) '读出地区
    
77.     Cells(1, 6) = "省份"
    
78.     For x = 1 To dic1.Count - 1
    
79.         brr(1, x) = VBA.Split(dic1.Keys(x - 1), vbTab)(0) '月份
    
80.         brr(2, x) = VBA.Split(dic1.Keys(x - 1), vbTab)(1) '水果
    
81.     Next x
    
82.     [G1].Resize(dic.Count + 1, dic1.Count) = brr '读出结果数组
    
83.     For x = 4 To dic1.Count - 1 Step dic2.Count + 1 '循环月份
    
84.         Range(Cells(1, x + dic2.Count), Cells(1, x + 2 * dic2.Count)).Merge   '设置格式月份合并
    
85.         Range(Cells(1, x + dic2.Count), Cells(1, x + 2 * dic2.Count)).HorizontalAlignment = xlCenter   '月份居中
    
86.     Next x
    
87.     Range(Cells(1, dic2.Count + 3), Cells(2, dic2.Count + 3)).Merge: Range(Cells(1, dic2.Count + 3), Cells(2, dic2.Count + 1)).HorizontalAlignment = xlCenter '省份
    
88.     Range(Cells(1, dic1.Count + 6), Cells(2, dic1.Count + 6)).Merge: Range(Cells(1, dic1.Count + 6), Cells(2, dic1.Count + 6)).HorizontalAlignment = xlCenter '合计
    
89.     Cells(1, dic1.Count + 6).Value = "合计"
    
90.     Range("F1").CurrentRegion.Select: Selection.Borders.LineStyle = 1: Columns("F:ZZ").EntireColumn.AutoFit '添加边框，自动适合列宽
    
91.     Application.DisplayAlerts = True
    
92.     Set dic = Nothing: Set dic1 = Nothing
    
93.     Erase arr, brr
    
94. End Sub
    
95. 
    
96. Sub 作业三()
    
97.     Dim IE As Object, readystate_complete
    
98.     Set IE = CreateObject("Internetexplorer.Application") '创建IE对象
    
99.     With IE
    
100.         .navigate "http://www.excelpx.com/forum-99-1.html" '打开精英培训网聊天室网页
     
101.         .Visible = True '可见
     
102.         Do Until IE.ReadyState = 4 '如果加载完成
     
103.         Loop
     
104.             .document.all("username").Value = "usedname" '输入用户名
     
105.             .document.all("password").Value = "passward" '输入密码
     
106.             .document.forms(0).submit '登陆
     
107.     End With
     
108.     Set IE = Nothing
     
109. End Sub
     

复制代码

hoogle

1. Option Explicit
   
2. Sub 作业一()
   
3. Dim arrData, arrRes(1 To 1000, 1 To 100)
   
4. Dim i, 行, 列
   
5. Set 行 = CreateObject("scripting.dictionary")
   
6. Set 列 = CreateObject("scripting.dictionary")
   
7. Sheet2.Select      '选择工作表
   
8. arrRes(1, 1) = Range("f1")
   
9. arrData = Range("a1").CurrentRegion.Offset(1)
   
10. For i = 1 To UBound(arrData)
    
11.     If arrData(i, 1) <> "" Then
    
12.         If Not 行.exists(arrData(i, 1)) Then 行(arrData(i, 1)) = 行.Count + 1
    
13.         If Not 列.exists(arrData(i, 2)) Then 列(arrData(i, 2)) = 列.Count + 1
    
14.         arrRes(行(arrData(i, 1)) + 1, 1) = arrData(i, 1)
    
15.         arrRes(1, 列(arrData(i, 2)) + 1) = arrData(i, 2)
    
16.         arrRes(行(arrData(i, 1)) + 1, 列(arrData(i, 2)) + 1) = arrRes(行(arrData(i, 1)) + 1, 列(arrData(i, 2)) + 1) + arrData(i, 3)
    
17.     End If
    
18. Next
    
19. Range("f1").CurrentRegion.ClearContents
    
20. Range("f1").Resize(1000, 100) = arrRes
    
21. End Sub
    
22. Sub 作业二()
    
23. Dim arrData, arrRes()
    
24. Dim i, j, d, bytMon(1 To 12), bytTemp, bytTemp2
    
25. Set d = CreateObject("scripting.dictionary")
    
26. Sheets("作业二").Select
    
27. For i = 1 To UBound(bytMon)
    
28.     bytMon(i) = i & "月"
    
29. Next
    
30. arrData = Range("a1").CurrentRegion
    
31. For i = 2 To UBound(arrData)
    
32.     d(arrData(i, 3)) = ""
    
33. Next
    
34. bytTemp = d.Count
    
35. d.RemoveAll  '重新利用，低碳生活
    
36. ReDim arrRes(1 To 1000, 1 To (bytTemp + 1) * 12 + 2)
    
37. bytTemp = 0
    
38. For i = 2 To UBound(arrData)
    
39.     If i = 2 Then
    
40.         arrRes(1, 1) = "省份"
    
41.         For j = 2 To UBound(arrRes, 2)
    
42.             If (j - 1) Mod ((UBound(arrRes, 2) - 2) / 12) = 1 Then arrRes(1, j) = (j - 1) \ ((UBound(arrRes, 2) - 2) / 12) + 1 & "月"
    
43.             If j Mod ((UBound(arrRes, 2) - 2) / 12) = 1 Then arrRes(2, j) = "小计"
    
44.             If j = UBound(arrRes, 2) Then arrRes(1, j) = "总计"
    
45.         Next
    
46.     End If
    
47.     If Not d.exists(arrData(i, 3)) Then
    
48.         bytTemp = bytTemp + 1
    
49.         d(arrData(i, 3)) = bytTemp
    
50.         For j = 2 To UBound(arrRes, 2)
    
51.         
    
52.             If (j - 1) Mod 4 = bytTemp Then arrRes(2, j) = arrData(i, 3)
    
53.         Next
    
54.     End If
    
55.     If Not d.exists(arrData(i, 2)) Then
    
56.         bytTemp2 = bytTemp2 + 1
    
57.         d(arrData(i, 2)) = bytTemp2
    
58.         arrRes(bytTemp2 + 2, 1) = arrData(i, 2)
    
59.     End If
    
60.     arrRes(d(arrData(i, 2)) + 2, (Val(Month(arrData(i, 1))) - 1) * ((UBound(arrRes, 2) - 2) / 12) + d(arrData(i, 3)) + 1) = _
    
61.     arrRes(d(arrData(i, 2)) + 2, (Val(Month(arrData(i, 1))) - 1) * ((UBound(arrRes, 2) - 2) / 12) + d(arrData(i, 3)) + 1) + arrData(i, 4)
    
62.     arrRes(d(arrData(i, 2)) + 2, (Val(Month(arrData(i, 1))) - 1) * (UBound(arrRes, 2) - 2) / 12 + (UBound(arrRes, 2) - 2) / 12 + 1) = _
    
63.     arrRes(d(arrData(i, 2)) + 2, (Val(Month(arrData(i, 1))) - 1) * (UBound(arrRes, 2) - 2) / 12 + (UBound(arrRes, 2) - 2) / 12 + 1) + arrData(i, 4)
    
64.     arrRes(d(arrData(i, 2)) + 2, UBound(arrRes, 2)) = arrRes(d(arrData(i, 2)) + 2, UBound(arrRes, 2)) + arrData(i, 4)
    
65. Next
    
66. Range("F1:BC1000").ClearContents
    
67. Range("F1").Resize(1000, UBound(arrRes, 2)) = arrRes
    
68. End Sub
    
69. 
    
70. Sub 作业三()
    
71. Dim i
    
72. For i = 2 To 4
    
73.     If i > 2 Then
    
74.         Application.Wait (Now + TimeValue("0:00:15"))   '两次发帖时间要间隔15秒
    
75.     End If
    
76.         With CreateObject("internetexplorer.application")
    
77.                 .Visible = True
    
78.                 .Navigate "http://www.excelpx.com/forum-99-1.html"
    
79.                 Do Until .ReadyState = 4
    
80.                     DoEvents
    
81.                 Loop
    
82.                 .Document.All.tags("li")(1).Click
    
83.                 .Document.getElementById("subject").Value = Sheet1.Cells(i, 1).Value
    
84.                 .Document.getElementById("fastpostmessage").Value = Sheet1.Cells(i, 2).Value
    
85.                 .Document.getElementById("fastpostsubmit").Click
    
86.         End With
    
87.         
    
88. Next
    
89. End Sub

复制代码

Sellby

作业三才做好

1. 
   
2. Sub 作业3()
   
3.     Dim ie As New InternetExplorer '创建一个IE对象
   
4.     Dim arr, i
   
5.     Dim myname$, mykey$
   
6.     myname = "VBA小菜菜"
   
7.     mykey = "123456"
   
8.     arr = ThisWorkbook.Sheets("作业三").Range("a1").CurrentRegion.Value
   
9.     For i = 2 To UBound(arr)
   
10.         With ie
    
11.             .Navigate "http://www.excelpx.com/forum-99-1.html" 'T
    
12.             .Visible = True '打开后要显示网页
    
13.             Do Until ie.ReadyState = READYSTATE_COMPLETE '如果IE加载宏完成
    
14.                 DoEvents '在窗体加载时转交操作权
    
15.             Loop
    
16.             With .Document
    
17.                 If InStr(1, .body.innertext, "注册") > 0 Then '判断是否已登录
    
18.                     .all("username").Value = myname 'Document.All("元素名称或ID") 可以引用某个元素
    
19.                     .all("password").Value = mykey '在密码框内输入密码
    
20.                     .forms(0).submit 'submit方法可以提交表单内容到服务器,froms(0)表示当前doc中第一个表单
    
21.                 End If
    
22.                 Application.Wait Now + TimeValue("0:00:05") '等待页面加载完全
    
23.                     .all("typeid").Value = "242" '选择主题分类
    
24.                     .all("subject").Value = arr(i, 1) '输入标题
    
25.                     .all("message").Value = arr(i, 2) '输入内容
    
26.                     .all("topicsubmit").Click '提交帖子
    
27.             End With
    
28. '            .Quit
    
29.             Application.Wait Now + TimeValue("0:00:15") '间隔15秒发帖
    
30. '            Stop
    
31.         End With
    
32.     Next i
    
33.     Set ie = Nothing
    
34. End Sub

复制代码