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

cloud-sj · 发表于 2013-12-9 13:44

本帖最后由 cloud-sj 于 2013-12-18 09:56 编辑

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

3-5要求一共占6分，每点2分，2道题最多扣6分
作业上交截止时间：2013年12月11日 20：00

E界白菜 · 发表于 2013-12-9 15:21

上交作业了。
请学委批改。
谢谢~~

qq1194660920 · 发表于 2013-12-9 15:54

Sub 作业一()
Dim arr, arr1, arr2, d, d1, d2, i, n, x, y, z, k, t
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
arr = Range("a2:c111")
For i = LBound(arr) To UBound(arr)
d(arr(i, 1) & arr(i, 2)) = d(arr(i, 1) & arr(i, 2)) + arr(i, 3)
d1(arr(i, 1)) = ""
d2(arr(i, 2)) = ""
Next
Range("g1").Resize(1, d2.Count) = d2.keys
Range("f2").Resize(d1.Count, 1) = Application.Transpose(d1.keys)
k = d.keys
t = d.items
ReDim arr1(1 To d1.Count, 1 To d2.Count)
arr2 = Range("f1").CurrentRegion
Stop
For n = 0 To UBound(k)
For x = 2 To UBound(arr2)
      If InStr(k(n), arr2(x, 1)) Then
      Debug.Print k(n)
      Debug.Print arr2(x, 1)
      y = x - 1
         For z = 2 To UBound(arr2, 2)
            If InStr(k(n), arr2(1, z)) Then
                  arr1(y, z - 1) = arr1(y, z - 1) + t(n)
            End If
         Next z
      End If
Next x
Next n
Stop
Range("l2").Resize(UBound(arr1), UBound(arr1, 2)) = arr1
Set arr = Nothing
Set arr1 = Nothing
Set arr2 = Nothing
Set d = Nothing
Set d1 = Nothing
Set d2 = Nothing
Set k = Nothing
Set t = Nothing
End Sub

Sub 作业二()
Dim d, d1, f, g, h, i, j, x, y, z, arr2, arr1, arr, k, t
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
arr = Range("a2:d111")
For i = LBound(arr) To UBound(arr)
d(arr(i, 2) & Month(arr(i, 1)) & "月" & arr(i, 3)) = d(arr(i, 2) & Month(arr(i, 1)) & "月" & arr(i, 3)) + arr(i, 4)
d1(arr(i, 2)) = ""
Next
Range("f3").Resize(d1.Count) = Application.Transpose(d1.keys)
k = d.keys
t = d.items
arr2 = Range("f1:bc13")
ReDim arr1(1 To UBound(arr2), 1 To UBound(arr2, 2))
For x = 3 To UBound(arr2)
For y = 2 To 50 Step 4
      For z = y To 50
         If arr2(2, z) = "小计" Then
            For f = 1 To 11
                  arr1(f, z - 1) = arr1(f, z - 2) + arr1(f, z - 3) + arr1(f, z - 4)
            Next
            GoTo 100
         End If
                  For j = LBound(k) To UBound(k)
                     If InStr(k(j), arr2(x, 1) & arr2(1, y) & arr2(2, z)) Then
                        arr1(x - 2, z - 1) = arr1(x - 2, z - 1) + t(j)
                     End If
                  Next
      Next
100:
Next
Next
For g = 1 To 11
For h = 4 To 48 Step 4
      arr1(g, 49) = arr1(g, 49) + arr1(g, h)
Next
Next
Range("g3").Resize(UBound(arr1), UBound(arr1, 2)) = arr1
Set d = Nothing
Set d1 = Nothing
Set arr = Nothing
Set arr1 = Nothing
Set arr2 = Nothing
End Sub

Sub 作业二附加题()
Dim d, d1, f, g, h, i, j, x, y, z, arr2, arr1, arr, k, t, a, b, c, e, ar, ar1, rng
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
arr = Range("a2:d111")
ar = Array("1月", "2月", "3月", "4月", "5月", "6月", "7月", "8月", "9月", "10月", "11月", "12月")
ar1 = Array("草莓", "苹果", "葡萄", "小计")
b = 0
e = 7
For a = 7 To 52 Step 4
Cells(1, a) = ar(b)
b = b + 1
If Cells(1, a + 3) = "" Then
         Range(Cells(1, a), Cells(1, a + 3)).Merge
         Cells(1, a).HorizontalAlignment = Excel.xlCenter
         End If
For c = LBound(ar1) To UBound(ar1)
      Cells(2, e) = ar1(c)
      e = e + 1

Next
Next
Cells(1, 6) = "省份"
Range(Cells(1, 6), Cells(2, 6)).Merge
Cells(1, 6).HorizontalAlignment = Excel.xlCenter
Cells(1, 55) = "合计"
Range(Cells(1, 55), Cells(2, 55)).Merge
Cells(1, 55).HorizontalAlignment = Excel.xlCenter
Range("f1:bc2").Interior.ColorIndex = 40
Range("f1:f13").Interior.ColorIndex = 40

For i = LBound(arr) To UBound(arr)
d(arr(i, 2) & Month(arr(i, 1)) & "月" & arr(i, 3)) = d(arr(i, 2) & Month(arr(i, 1)) & "月" & arr(i, 3)) + arr(i, 4)
d1(arr(i, 2)) = ""
Next
Range("f3").Resize(d1.Count) = Application.Transpose(d1.keys)
k = d.keys
t = d.items
arr2 = Range("f1:bc13")
ReDim arr1(1 To UBound(arr2), 1 To UBound(arr2, 2))
For x = 3 To UBound(arr2)
For y = 2 To 50 Step 4
      For z = y To 50
         If arr2(2, z) = "小计" Then

            For f = 1 To 11
                  arr1(f, z - 1) = arr1(f, z - 2) + arr1(f, z - 3) + arr1(f, z - 4)
            Next
            GoTo 100
         End If

                  For j = LBound(k) To UBound(k)
                     If InStr(k(j), arr2(x, 1) & arr2(1, y) & arr2(2, z)) Then
                        arr1(x - 2, z - 1) = arr1(x - 2, z - 1) + t(j)
                     End If
                  Next
      Next
100:
Next
Next
For g = 1 To 11
Debug.Print arr1(g, 49)
For h = 4 To 48 Step 4
      arr1(g, 49) = arr1(g, 49) + arr1(g, h)
Next
Next
Range("g3").Resize(UBound(arr1), UBound(arr1, 2)) = arr1
Range("f1:bc13").Borders.LineStyle = 1
Set d = Nothing
Set d1 = Nothing
Set ar = Nothing
Set ar1 = Nothing
Set arr = Nothing
Set arr1 = Nothing
Set arr2 = Nothing
End Sub

木牙水 · 发表于 2013-12-9 16:22

【VBA字典数组201301班】-A10-木牙水.rar (44.49 KB, 下载次数: 25)

午夜洗衣机 · 发表于 2013-12-9 17:51

本帖最后由午夜洗衣机于 2013-12-10 11:50 编辑

作业3好坑啊,居然跟IE版本都有关

Option Explicit
Sub 作业1()
Dim dq As New Dictionary
Dim pz As New Dictionary
Dim d As New Dictionary
Dim arr, brr()
Dim i, j As Long
Dim str As String
arr = Range("a1").CurrentRegion.Value
For i = 2 To UBound(arr)
pz(arr(i, 2)) = "" '字典pz:品种
Next
For i = 2 To UBound(arr)
If Not dq.Exists(str) Then dq(arr(i, 1)) = "" '地区
str = arr(i, 1) & "|" & arr(i, 2) '临时变量,将地区和品种相连作为关键字
d(str) = d(str) + arr(i, 3)
'地区+品种=数量汇总
Next
If dq.Count = 0 Then Exit Sub
ReDim brr(1 To dq.Count, 1 To pz.Count + 1) '重定义数组的大小
arr = dq.Keys
For i = 1 To dq.Count '行循环
brr(i, 1) = arr(i - 1) '第一列:地区
For j = 2 To pz.Count + 1
str = arr(i - 1) & "|" & pz.Keys(j - 2)
If d.Exists(str) Then brr(i, j) = d(str)
Next
Next
Range("g1").Resize(, pz.Count) = pz.Keys
Range("f2").Resize(i - 1, pz.Count + 1) = brr
End Sub
Sub 作业2()
Dim dq As New Dictionary
Dim pz As New Dictionary
Dim d As New Dictionary
Dim arr, brr(), k
Dim x, i, j As Long
Dim str, sr As String
arr = Range("G2:J2").Value
'以下是列标题做关键字的字典
For x = 1 To 12
For i = 1 To 4 '内循环
str = x & "月" & "|" & arr(1, i) '月份加品种
j = j + 1 '列标
pz(str) = j
Next
Next
arr = Range("a1").CurrentRegion.Value
'以下是做了两个字典,一个是数量汇总,一个是取地区名称
For i = 2 To UBound(arr)
If Not dq.Exists(arr(i, 2)) Then dq(arr(i, 2)) = ""
sr = arr(i, 2) & "|" & Month(arr(i, 1)) & "月" & "|" & arr(i, 3) '地区+月份+品种
str = arr(i, 2) & "|" & Month(arr(i, 1)) & "月" & "|" & "小计" '地区+月份+小计
d(sr) = d(sr) + arr(i, 4)
d(str) = d(str) + arr(i, 4) '在字典里加入小计作为keys,相同的地区+月份汇总
d(arr(i, 2)) = d(arr(i, 2)) + arr(i, 4) '按地区总计
Next
ReDim brr(1 To dq.Count, 1 To pz.Count + 2) '调整动态数组大小
k = dq.Keys '地区关键字
On Error Resume Next '如果错误执行下一句因为数据源没有12月数据,如果没有这句会报错
'以下是进行收据透视表式排列
For i = 1 To dq.Count '行循环
brr(i, 1) = k(i - 1) '第1列:地区
brr(i, 50) = d(k(i - 1)) '填入总计数量
For j = 2 To pz.Count
sr = k(i - 1) & "|" & pz.Keys(j - 2) '地区+日期+品种
If d.Exists(sr) Then
brr(i, j) = d(sr)
End If
Next
Next
If Range("f3") <> "" Then Range("f3:bc" & Cells(Rows.Count, 6).End(xlUp).row).ClearContents
'如果第3行不为空才执行删除命令,以免误删标题行
Range("f3").Resize(dq.Count, pz.Count + 2) = brr
MsgBox "汇总完成!"
End Sub
Sub 作业3批量发贴()
'批量发帖
Dim ie As New InternetExplorer '创建一个IE对象
Dim arr
Dim i As Integer
Dim t As Long
arr = Range("a2:b4")
For i = 1 To UBound(arr)
With ie
.Navigate "http://www.excelpx.com/forum.php?mod=post&action=newthread&fid=99"
'Navigate方法,可以打开指定的网页:精英聊天室->发起帖子
.Visible = True '打开后要显示网页
Do Until ie.ReadyState = READYSTATE_COMPLETE '如果IE加载宏完成
'DoEvents '在窗体加载时转交操作权
Loop
' .Document.getElementById("typeid").Value = 242 '选择主题分类为"文字",IE10用这一行
.Document.getElementById("typeid_ctrl_menu").All.tags("li")(5).Click '选择主题分类为"活动",IE8要用这一行
.Document.All("subject").Value = arr(i, 1)
.Document.All("message").Value = arr(i, 2)
.Document.Forms(1).submit '网页中第2个表格,第1个是Forms(0)
End With
Application.Wait (Now + TimeValue("00:00:20")) '论坛有发贴时间间隔设置,延时20秒
Next
ie.Quit '关闭网页.
Set ie = Nothing
End Sub

复制代码

CheryBTL · 发表于 2013-12-10 12:10

本帖最后由 CheryBTL 于 2013-12-10 20:15 编辑

Sub 作业一CheryBTL()
Dim ar, re
Dim i As Long, R As Integer, C As Integer
Dim Rcnt As Integer, Ccnt As Integer
Dim dR As Object, dC As Object '//定义字典dR为行标,dC为列标
Set dR = CreateObject("scripting.dictionary")
Set dC = CreateObject("scripting.dictionary")
ar = Sheets("作业一").Range("a1").CurrentRegion '//将源数据赋值给数组ar
ReDim re(1 To 50, 1 To 30)
If Not IsArray(ar) Then
MsgBox "数据不符合要求" '//若源数据为非数组，则退出代码
Exit Sub
End If
For i = 2 To UBound(ar)
If Not dR.exists(ar(i, 1)) Then
'//对地区按出现顺序编号放入字典dR中，其对应的Item为出现的顺序数，即行标
Rcnt = Rcnt + 1
dR(ar(i, 1)) = Rcnt
End If
If Not dC.exists(ar(i, 2)) Then
'//对品种按出现顺序编号放入字典dR中，其对应的Item为出现的顺序数,即列标
Ccnt = Ccnt + 1
dC(ar(i, 2)) = Ccnt
End If
R = dR(ar(i, 1)) '//提取行标
C = dC(ar(i, 2)) '//提取列标
re(R, C) = re(R, C) + ar(i, 3) '//对应的结果数据累加
Next i
With Sheets("作业一")
.[f2].Resize(dR.Count) = Application.Transpose(dR.keys) '//输出地区
.[g1].Resize(1, dC.Count) = (dC.keys) '//输出品种
.[g2].Resize(UBound(re), UBound(re, 2)) = re '//输出累计数量
End With
End Sub

复制代码

Sub 作业二CheryBTL()
Dim ar, re, temp
Dim i As Long, j As Long, k As Long, R As Integer, C As Integer
Dim Cnt As Integer, M As Integer, Cnt2 As Integer
Dim d1 As Object, d2 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
'//d1为地区的不重复清单及对应的顺序，即行标
'//d2为品种对应的不重复清单及对应的顺序，即列标（需再加上月份的信息）
ar = Sheets("作业二").Range("a1").CurrentRegion '//源数据赋值给数组ar
ReDim re(1 To 31, 1 To 49) '//根据结果数组的区域，重定义结果数组
For i = 2 To UBound(ar)
If Not d2.exists(ar(i, 3)) Then
'//对品种按出现顺序编号放入字典dR中，其对应的Item为出现的顺序数,即列标
Cnt2 = Cnt2 + 1
d2(ar(i, 3)) = Cnt2
End If
Next i
For i = 2 To UBound(ar)
If Not d1.exists(ar(i, 2)) Then
'//对地区按出现顺序编号放入字典dR中，其对应的Item为出现的顺序数，即行标
Cnt = Cnt + 1
d1(ar(i, 2)) = Cnt
End If
M = Month(ar(i, 1)) * 4 - 4 '//月份信息
R = d1(ar(i, 2)) '//行标
C = d2(ar(i, 3)) + M '//列标
re(R, C) = re(R, C) + ar(i, 4) '//对应品种对应月份累计
re(R, M + 4) = re(R, M + 4) + ar(i, 4) '//对应地区对应月份累计
re(R, 49) = re(R, 49) + ar(i, 4) '//对应地区累计
Next
With Sheets("作业二")
.Range("F3:BC50").ClearContents
.[f3].Resize(d1.Count) = Application.Transpose(d1.keys) '//输出地区数据
.[g3].Resize(UBound(re), UBound(re, 2)) = re '//输出汇总结果
End With
End Sub

复制代码

Sub 作业二附加CheryBTL() '//品种增加时自动汇总，但格式没有处理，需要把格式完善了。
Dim ar, re, temp
Dim i As Long, j As Long, k As Long, R As Integer, C As Integer
Dim Cnt As Integer, Cnt2 As Integer, M As Integer
Dim d1 As Object, d2 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
'//d1为地区的不重复清单及对应的顺序，即行标
'//d2为品种对应的不重复清单及对应的顺序，即列标（需再加上月份的信息）
ar = Sheets("作业二").Range("a1").CurrentRegion '//源数据赋值给数组ar
For i = 2 To UBound(ar)
If Not d2.exists(ar(i, 3)) Then
'//对品种按出现顺序编号放入字典d2中，其对应的Item为出现的顺序数,即列标的参考
Cnt2 = Cnt2 + 1
d2(ar(i, 3)) = Cnt2
End If
Next i
d2("小计") = Cnt2 + 1 '//将小计放入字典d2中
ReDim re(1 To 33, 1 To d2.Count * 12 + 1) '//根据结果区域的大小，定义结果数组
'//以下对表头进行处理
'//将字典d2的keys赋值对临时数据temp
temp = d2.keys
For i = 1 To UBound(re, 2) - 1
If i Mod d2.Count = 1 Then re(1, i) = Int((i - 1) / d2.Count) + 1 & "月"
'//若i为d2.count的整数倍+1时，定义为月份信息
re(2, i) = temp((i - 1) Mod d2.Count)
'//按0、1、2、d2.count-1的顺序赋值对第二行表头
Next i
re(2, i) = "合计" '//最后一行的数据为合计
Cnt = 2 '//因为前面有2行表头，数据要从第3行开始，因为起始值为2
For i = 2 To UBound(ar)
If Not d1.exists(ar(i, 2)) Then
'//对地区按出现顺序编号放入字典dR中，其对应的Item为出现的顺序数，即行标
Cnt = Cnt + 1
d1(ar(i, 2)) = Cnt
End If
M = Month(ar(i, 1)) * d2.Count - d2.Count '月份信息，即月份的间隔
R = d1(ar(i, 2)) '行标
C = d2(ar(i, 3)) + M '列标
re(R, C) = re(R, C) + ar(i, 4) '//对应品种对应月份累计
re(R, M + d2.Count) = re(R, M + d2.Count) + ar(i, 4) '//对应地区对应月份累计
re(R, UBound(re, 2)) = re(R, UBound(re, 2)) + ar(i, 4) '//对应地区累计
Next
With Sheets("作业二")
.Range("G1:VV65536").Clear '//清楚原数据的内容及格式
.[f3].Resize(d1.Count) = Application.Transpose(d1.keys) '//输出地区
.[g1].Resize(UBound(re), UBound(re, 2)) = re '输出结果数据
.Range(.Cells(1, 7), .Cells(2, 6 + UBound(re, 2))).Select '//以下都是格式设置的信息，选中表头
With Selection.Interior '//设置填充色
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.399975585192419
End With
For i = 1 To UBound(re, 2) - 1 Step d2.Count '//设置第一列的合并单元格
.Range(.Cells(1, i + 6), .Cells(1, i + d2.Count + 5)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.ReadingOrder = xlContext
End With
Selection.Merge
Next i
.Range(.Cells(1, i + 6), .Cells(2, i + 6)).Select '//设计总计的合并单元格
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.ReadingOrder = xlContext
End With
Selection.Merge
.Range(.Cells(1, 6), .Cells(2 + d1.Count, 6 + UBound(re, 2))).Select '增加边框
With Selection.Borders
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End With
End Sub

复制代码

开心妙妙 · 发表于 2013-12-10 15:41

Option Explicit
Sub 作业一A03开心妙妙()
Dim D As New Dictionary, DD As New Dictionary, D1 As New Dictionary, D2 As New Dictionary
Dim Arr, ARR2(), Arr3
Dim i, s, j, s1, c, r
Application.ScreenUpdating = False '禁止屏幕刷新
Arr = Range("A2:C" & Range("A65536").End(xlUp).Row) '数据将入数组
For i = 1 To UBound(Arr)
If D.Exists(Arr(i, 2)) = False Then D(Arr(i, 2)) = 0 '字典品种
D(Arr(i, 2)) = D(Arr(i, 2)) + Arr(i, 3) '品种数据汇总
If DD.Exists(Arr(i, 1)) = False Then DD(Arr(i, 1)) = 0 '字典地区
DD(Arr(i, 1)) = DD(Arr(i, 1)) + Arr(i, 3) '地区数据汇总
If Not D1.Exists(Arr(i, 1)) Then D1(Arr(i, 1)) = "" '字典地区
s = Arr(i, 1) & "|" & Arr(i, 2) '第一列连第二列作为D2的关键字
D2(s) = D2(s) + Arr(i, 3) '地区+品种——数据汇总
Next i
c = Range("G1").End(xlToRight).Column '列号
r = Range("F2").End(xlDown).Row '行号
Range(Cells(1, 7), Cells(1, c)).Clear '品种列标题内容清空
Range(Cells(2, 6), Cells(r, c)).Clear '清空原目标区域内容
If D1.Count = 0 Then Exit Sub '如果字典地区条目数是0,退出程序
ReDim ARR2(1 To D1.Count, 1 To D.Count + 1) '否则就重置结果数组
Arr3 = D1.Keys '将字典地区放入数组Arr3
For i = 1 To D1.Count '数组行循环
ARR2(i, 1) = Arr3(i - 1) '将地区列放入目标数组第一列
For j = 2 To D.Count + 1 '数组列循环,第一列是地区,所以从第二列开始循环,列数是品种的条目数
s = Arr3(i - 1) & "|" & D.Keys(j - 2) '地区连品种作为关键字
If D2.Exists(s) Then ARR2(i, j) = D2(s) '如果关键字存在,那么,将值放进数组中
Next j
Next i
c = D.Count '品种条目数计算列
r = DD.Count '地区条目数计算行
Range("F2").Resize(r, c + 1) = ARR2 '将Arr2赋值到单元格区域
Cells(1, c + 7) = "合计" '最后一列填入"合计"字符
Range("G1").Resize(, c) = D.Keys '将品种标题赋值到单元格中
Range("G1").Resize(, c + 1).HorizontalAlignment = xlCenter '将品种标题列居中
With Range("F1").Resize(, c + 2).Interior '品种标题区域内部对象
.ThemeColor = xlThemeColorAccent6 '对象设置颜色
.TintAndShade = 0.799981688894314 '对象颜色减淡
End With
Cells(2, c + 7).Resize(r, 1) = Application.WorksheetFunction.Transpose(DD.Items) '字典地区汇总值放入赋值到合计列
Cells(r + 2, 6) = "总计" '最后行填入"总计"字符
Cells(r + 2, 7).Resize(, c) = D.Items '字典品种汇总填入区域
Cells(r + 2, c + 7) = Application.WorksheetFunction.Sum(Range(Cells(2, c + 7), Cells(r + 1, c + 7))) '汇总K列数据
Range(Cells(1, 6), Cells(r + 2, c + 7)).Borders.LineStyle = 1 '区域添加框条
Range(Cells(2, 6), Cells(r + 2, 6)).HorizontalAlignment = xlCenter '地区列居中
Application.ScreenUpdating = True '开启屏幕刷新
End Sub

复制代码

ldxhzy · 发表于 2013-12-11 09:05

只做了第一题，第二题实在不会，请老师手下留情。

123小木头人 · 发表于 2013-12-11 17:08

A组长:123小木头人第二题没思路第三题做了登陆的
Sub 作业一()
Dim d As New Dictionary, d1 As New Dictionary
Dim arr, arr1(1 To 1000, 1 To 10)
Dim i%, m%, n%
'数据源放入数组
arr = Range("a2:c" & Cells(Rows.Count, 1).End(xlUp).Row).Value

'处理结果放入数组
For i = LBound(arr) To UBound(arr)
If Not d.Exists(arr(i, 1)) Then d(arr(i, 1)) = d.Count + 1
If Not d1.Exists(arr(i, 2)) Then d1(arr(i, 2)) = d1.Count + 1
m = d(arr(i, 1)): n = d1(arr(i, 2))
arr1(m, n) = arr1(m, n) + arr(i, 3)
Next i

  '放入单元格区域
Range("f:l").ClearContents
Range("f1") = " 品种" & " " & Chr(10) & "地区"
Range("g2").Resize(UBound(arr1), UBound(arr1, 2)) = arr1
Range("f2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Keys)
Range("g1").Resize(1, d1.Count) = d1.Keys
End Sub

Sub 作业二()
Dim d As New Dictionary, d1 As New Dictionary, d2 As New Dictionary
Dim arr, arr1(), arr2
Dim i%, m%, n%, str$, j%
arr2 = Array("草莓", "苹果", "葡萄", "小计")
arr = Range("a2:d" & Cells(Rows.Count, 1).End(xlUp).Row).Value
  For i = LBound(arr) To UBound(arr)
If Not d.Exists(arr(i, 2)) Then d(arr(i, 2)) = d.Count + 1
  Next i
  ReDim arr1(1 To d.Count, 1 To 48)
  For i = LBound(arr) To UBound(arr)
For j = 1 To d.Count
   For n = 0 To 2
   str = VBA.Month(arr(i, 1)) & d.Keys(j - 1) & arr2(0)
   Next n
Next j
  Next i
End Sub

Sub 打开论坛(name As String, word As String)
Dim ie As New InternetExplorer
Dim i, arr(1 To 1000)
  With ie
.Navigate "http://www.excelpx.com"
.Visible = True
  Do Until .ReadyState = READYSTATE_COMPLETE
  Loop
.Document.all("username").Value = name
.Document.all("password").Value = word
.Document.forms(0).submit
  End With
End Sub

索性乱来 · 发表于 2015-1-29 16:20

俗是俗了点儿。可是我喜欢

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

[通知] 【VBA字典数组201301班】A组-第五讲作业上交贴

相关帖子

点评

评分

点评

评分

点评

评分

哦

点评

评分

点评

评分

点评

评分

点评

评分

点评

评分