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

sliang28 · 发表于 2013-12-7 18:38

本帖最后由 sliang28 于 2013-12-20 09:22 编辑

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

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

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

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

风林火山 · 发表于 2013-12-10 18:58

本帖最后由风林火山于 2013-12-10 19:01 编辑

Sub work1()
Dim arr, brr, crr, drr
Dim d_dq As Object, d_pz As Object, d_hz As Object
Dim k%, i%, j%, m%, n%, str1$, str2$
Set d_dq = CreateObject("scripting.dictionary")
Set d_pz = CreateObject("scripting.dictionary")
Set d_hz = CreateObject("scripting.dictionary")
'数组赋值
arr = Range("A1").CurrentRegion
'生成字典数据
For k = 2 To UBound(arr)
      If d_dq.exists(arr(k, 1)) = False Then d_dq(arr(k, 1)) = ""
      If d_pz.exists(arr(k, 2)) = False Then d_pz(arr(k, 2)) = ""
      str1 = arr(k, 1) & arr(k, 2)
      If d_hz.exists(str1) = False Then
         d_hz(str1) = arr(k, 3)
      Else
         d_hz(str1) = d_hz(str1) + arr(k, 3)
      End If
Next k
'重新定义数组维度
ReDim brr(1 To d_dq.Count + 1, 1 To d_pz.Count + 1)
'字典转成数组数据
crr = d_dq.keys
drr = d_pz.keys
'数据填充
For i = 0 To UBound(crr)
      brr(i + 2, 1) = crr(i)
Next i
For j = 0 To UBound(drr)
      brr(1, j + 2) = drr(j)
Next j
For m = 2 To UBound(brr)
      For n = 2 To UBound(brr, 2)
         str2 = brr(m, 1) & brr(1, n)
         brr(m, n) = d_hz(str2)
      Next n
Next m
brr(1, 1) = " 品种" & " " & Chr(10) & "地区"
'数据显示和格式设置
Range("f:l").Delete
Range("f1").Resize(UBound(brr), UBound(brr, 2)) = brr
Range("f1").CurrentRegion.Borders.LineStyle = xlContinuous
Range("f1").Borders(xlDiagonalDown).LineStyle = xlContinuous
End Sub

Sub work1_2()
Dim arr, brr()
Dim d_dq As Object, d_pz As Object
Dim k%, i%, j%, m%, n%, str1$, str2$
Set d_dq = CreateObject("scripting.dictionary")
Set d_pz = CreateObject("scripting.dictionary")
'数组赋值
arr = Range("A1").CurrentRegion
'生成不重复地区和品种数据，并汇总
For k = 2 To UBound(arr)
      If d_dq.exists(arr(k, 1)) = False Then d_dq(arr(k, 1)) = d_dq.Count + 1
      If d_pz.exists(arr(k, 2)) = False Then d_pz(arr(k, 2)) = d_pz.Count + 1
      ReDim Preserve brr(1 To UBound(arr), 1 To d_pz.Count + 1)
      m = d_dq(arr(k, 1)) + 1: n = d_pz(arr(k, 2)) + 1
      brr(m, n) = brr(m, n) + arr(k, 3)
Next k

brr(1, 1) = " 品种" & " " & Chr(10) & "地区"
'数据显示和格式设置
Range("f:l").Delete
Range("f1").Resize(UBound(brr), UBound(brr, 2)) = brr
Range("f2").Resize(d_dq.Count, 1) = Application.WorksheetFunction.Transpose(d_dq.keys)
Range("g1").Resize(1, d_pz.Count) = d_pz.keys
Range("f1").CurrentRegion.Borders.LineStyle = xlContinuous
Range("f1").Borders(xlDiagonalDown).LineStyle = xlContinuous
End Sub

Sub work2()
Dim arr, brr()
Dim k%, i%, j%, hb%, m%, n%, str1$
Dim d1 As Object, d2 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
'数组赋值
arr = Sheets("作业二").Range("a1").CurrentRegion
'重新定义数组维数
ReDim brr(1 To UBound(arr), 1 To 100)
Application.ScreenUpdating = False
'用字典保存数据所在列数和第二行列标题赋值
For k = 1 To 12
      d1(k & "月" & "草莓") = d1.Count + 1: brr(2, k * 4 - 2) = "草莓": brr(1, k * 4 - 2) = k & "月"
      d1(k & "月" & "苹果") = d1.Count + 1: brr(2, k * 4 - 1) = "苹果"
      d1(k & "月" & "葡萄") = d1.Count + 1: brr(2, k * 4) = "葡萄"
      d1(k & "月" & "小计") = d1.Count + 1: brr(2, k * 4 + 1) = "小计"
Next k
d1("总计") = ""
'需要合并的单元格单独赋值
brr(1, 1) = "省份": brr(1, 50) = "总计"
'通过字典汇总3类数据，品种、小计、总计
For i = 2 To UBound(arr)
If d2.exists(arr(i, 2)) = False Then
d2(arr(i, 2)) = d2.Count + 3 '+3的目的是为下面循环做准备，也就是直接就是不包括标题行循环
End If
'分别取出行号m、列号n和总计列号j，循环赋值
m = d2(arr(i, 2)): n = d1(Month(arr(i, 1)) & "月" & arr(i, 3)) + 1: j = d1(Month(arr(i, 1)) & "月小计") + 1
brr(m, n) = brr(m, n) + arr(i, 4)
brr(m, j) = brr(m, j) + arr(i, 4)
brr(m, 50) = brr(m, 50) + arr(i, 4)
Next i
'在指定区域显示数据
[f1].Resize(UBound(brr), UBound(brr, 2)) = brr
'添加省份数据
Range("f3").Resize(d2.Count, 1) = Application.WorksheetFunction.Transpose(d2.keys)
'循环合并首行月份标题
For hb = 1 To 12
      Sheets("作业二").Range(Cells(1, hb * 4 + 3), Cells(1, hb * 4 + 6)).Select
      Selection.HorizontalAlignment = xlCenter
      Selection.Merge
Next hb
'合并总计和省份标题
Sheets("作业二").[bc1:bc2].Select
Selection.HorizontalAlignment = xlCenter
Selection.Merge
Sheets("作业二").[f1:f2].Select
Selection.HorizontalAlignment = xlCenter
Selection.Merge
'数据区域格式设置
Sheets("作业二").Range("f1").CurrentRegion.Borders.LineStyle = xlContinuous
Sheets("作业二").Range("f1").CurrentRegion.Select
Selection.Interior.ColorIndex = 45
Sheets("作业二").Range("g3:bc13").Select
Selection.Interior.ColorIndex = 34
Application.ScreenUpdating = True
[f1].Select
End Sub
Sub 自动发帖()
' On Error Resume Next
With CreateObject("internetexplorer.application")
      .Visible = True
      .Navigate "http://www.excelpx.com/member.php?mod=logging&action=login&loginsubmit=yes&infloat=yes&lssubmit=yes&username=用户名&password=pass" '登录
      Do Until .ReadyState = 4
         DoEvents
      Loop
      .Navigate "http://www.excelpx.com/forum.php?mod=post&action=newthread&fid=99&referer=http%3A//www.excelpx.com/forum-99-1.html"

End With

End Sub

fffox · 发表于 2013-12-10 22:05

D09:fffox上交作业
作业一：

Sub 作业一_a()
Dim arr, brr(), Dq, Pz
Dim d_dq, d_pz, d
Dim i&, j%
Set d_dq = CreateObject("scripting.dictionary") '地区
Set d_pz = CreateObject("scripting.dictionary") '品种
Set d = CreateObject("scripting.dictionary") '数量
arr = Sheets("作业一").Range("a1").CurrentRegion
For i = 2 To UBound(arr) '源数组内循环，分别以地区、品种及地区&品种为关键字创建字典
d_dq(arr(i, 1)) = ""
d_pz(arr(i, 2)) = ""
d(arr(i, 1) & arr(i, 2)) = d(arr(i, 1) & arr(i, 2)) + arr(i, 3)
Next
Pz = d_pz.Keys
Dq = d_dq.Keys
'根据地区、品种字典大小，重新定义结果数组
ReDim brr(1 To d_dq.Count + 1, 1 To d_pz.Count + 1)
brr(1, 1) = " 品种" & vbCrLf & "地区"
For j = 2 To UBound(brr, 2) '标题行
brr(1, j) = Pz(j - 2)
Next
For i = 2 To UBound(brr)
brr(i, 1) = Dq(i - 2) '地区列
For j = 2 To UBound(brr, 2)
brr(i, j) = d(brr(i, 1) & brr(1, j)) '从字典中取数
Next
Next
With Sheets("作业一").Range("f1") '设置格式及数据写入目标区域
.Resize(Rows.Count, 7).Clear
.Borders(xlDiagonalDown).LineStyle = 1 '斜线
.Offset(0, 1).Resize(1, d_pz.Count).HorizontalAlignment = xlCenter '水平距中
.Offset(1, 0).Resize(d_dq.Count).HorizontalAlignment = xlCenter
With .Resize(d_dq.Count + 1, d_pz.Count + 1)
.Value = brr
.Borders(7).LineStyle = 1 '区域左边的边框
.Borders(8).LineStyle = 1 '区域顶部的边框
.Borders(9).LineStyle = 1 '区域底部的边框
.Borders(10).LineStyle = 1 '区域右边的边框
.Borders(11).LineStyle = 1 '区域中所有单元格的垂直边框
.Borders(12).LineStyle = 1 '区域中所有单元格的水平边框
End With
End With
End Sub
Sub 作业一_b()
Dim arr, brr(1 To 100, 1 To 100), d_dq, d_pz
Dim i&, j%, iRow As Byte, iCol As Byte, k_Row%, k_Col%
Set d_dq = CreateObject("scripting.dictionary")
Set d_pz = CreateObject("scripting.dictionary")
arr = Sheets("作业一").Range("a1").CurrentRegion
k_Row = 1: k_Col = 1
For i = 2 To UBound(arr)
If Not d_dq.Exists(arr(i, 1)) Then
k_Row = k_Row + 1 '数值增加1
iRow = k_Row '行号
d_dq(arr(i, 1)) = k_Row '新行号存入字典
brr(iRow, 1) = arr(i, 1) '地区
Else
iRow = d_dq(arr(i, 1)) '从字典中取行号
End If
If Not d_pz.Exists(arr(i, 2)) Then
k_Col = k_Col + 1 '列数值增加1
iCol = k_Col '列号
d_pz(arr(i, 2)) = iCol '列号存入字典
brr(1, iCol) = arr(i, 2) '品种
Else
iCol = d_pz(arr(i, 2)) '从字典中取列号
End If
brr(iRow, iCol) = brr(iRow, iCol) + arr(i, 3)
Next
brr(1, 1) = " 品种" & vbCrLf & "地区"
With Sheets("作业一").Range("t1")
.Resize(Rows.Count, 7).Clear
.Borders(xlDiagonalDown).LineStyle = 1 '斜线
.Offset(0, 1).Resize(1, d_pz.Count).HorizontalAlignment = xlCenter '水平距中
.Offset(1, 0).Resize(d_dq.Count).HorizontalAlignment = xlCenter
With .Resize(d_dq.Count + 1, d_pz.Count + 1)
.Value = brr
.Borders(7).LineStyle = 1 '单元格边框线
.Borders(8).LineStyle = 1
.Borders(9).LineStyle = 1
.Borders(10).LineStyle = 1
.Borders(11).LineStyle = 1
.Borders(12).LineStyle = 1
End With
End With
End Sub

复制代码

作业二：

Sub 作业二A()
Dim arr, brr(), d
Dim i%, j As Byte, iRow%, iCol%, k%
Const str As String = "草莓苹果葡萄"
Set d = CreateObject("scripting.dictionary")
arr = Sheets("作业二").Range("a1").CurrentRegion
For i = 2 To UBound(arr)
'计算结果数组中的列号
iCol = (Month(arr(i, 1)) - 1) * 4 + (InStr(str, arr(i, 3)) + 1) / 2 + 1
If Not d.Exists(arr(i, 2)) Then
k = k + 1
iRow = k '行号
d(arr(i, 2)) = k
ReDim Preserve brr(1 To 50, 1 To k) '重新定义结果数组
brr(1, k) = arr(i, 2)
Else
iRow = d(arr(i, 2))
End If
brr(iCol, iRow) = brr(iCol, iRow) + arr(i, 4) '结果数组赋值
Next
For i = 1 To k '计算小计及合计
For j = 1 To 12
brr(4 * j + 1, i) = brr(4 * j - 2, i) + brr(4 * j - 1, i) + brr(4 * j, i)
brr(50, i) = brr(50, i) + brr(4 * j + 1, i)
Next
Next
With Sheets("作业二").Range("f3")
.Resize(1000, 50).ClearContents
.Resize(k, 50) = WorksheetFunction.Transpose(brr)
End With
End Sub

复制代码

作业二：附加，可自动适应月份、品种变化增减标题

Sub 作业二B()
Dim arr, brr()
Dim dMon As New Dictionary '创建月份字典
Dim dDq As New Dictionary '创建地区字典
Dim dPz As New Dictionary '创建品种字典
Dim d As New Dictionary '创建数量字典
Dim x%, y%, z%, k%, str$, ColEnd%, RowEnd%
Dim Mon, Dq, Pz
'读入源数据，字典赋值
arr = Sheets("作业二").Range("a1").CurrentRegion
For x = 0 To 2
dPz.Add Array("草莓", "苹果", "葡萄")(x), ""
Next
For x = 2 To UBound(arr)
str = Month(arr(x, 1)) & "月" & arr(x, 2) & arr(x, 3)
d(str) = d(str) + arr(x, 4)
dMon(Month(arr(x, 1))) = ""
dDq(arr(x, 2)) = ""
If Not dPz.Exists(arr(x, 3)) Then dPz(arr(x, 3)) = ""
Next
'重新声明结果数组，标题行赋值
k = dPz.Count + 1
ColEnd = dMon.Count * k + 2
RowEnd = dDq.Count + 2
ReDim brr(1 To RowEnd, 1 To ColEnd)
For x = 1 To dMon.Count
brr(1, k * (x - 1) + 2) = dMon.Keys(x - 1) & "月"
For y = 1 To k - 1
brr(2, k * (x - 1) + y + 1) = dPz.Keys(y - 1)
Next
brr(2, k * (x - 1) + y + 1) = "小计"
Next
brr(1, 1) = "省份"
brr(1, ColEnd) = "合计"
For x = 3 To RowEnd
brr(x, 1) = dDq.Keys(x - 3)
For y = 1 To dMon.Count
For z = 1 To k - 1
str = brr(1, k * (y - 1) + 2) & brr(x, 1) & brr(2, k * (y - 1) + z + 1)
brr(x, k * (y - 1) + z + 1) = d(str)
brr(x, k * y + 1) = brr(x, k * y + 1) + brr(x, k * (y - 1) + z + 1) '小计
Next
brr(x, ColEnd) = brr(x, ColEnd) + brr(x, k * y + 1) '合计
Next
Next
'目标区域赋值，格式设置
With Sheets("作业二")
.Range("bf1", .Cells(Rows.Count, .Cells(1, Columns.Count).End(xlToLeft).Column)).Clear
With .Range("bf1")
.Resize(2, ColEnd).HorizontalAlignment = xlCenter '标题行居中
.Resize(2, ColEnd).Interior.Color = RGB(255, 204, 153)
.Resize(RowEnd).HorizontalAlignment = xlCenter '地区列居中
.Resize(RowEnd).Interior.Color = RGB(255, 204, 153)
.Resize(2).Merge '单元格合并
.Offset(0, ColEnd - 1).Resize(2).Merge
For x = 1 To dMon.Count
.Offset(0, k * (x - 1) + 1).Resize(1, k).Merge
Next
With .Resize(RowEnd, ColEnd)
.Value = brr
.Borders(7).LineStyle = 1 '单元格边框
.Borders(8).LineStyle = 1
.Borders(9).LineStyle = 1
.Borders(10).LineStyle = 1
.Borders(11).LineStyle = 1
.Borders(12).LineStyle = 1
End With
End With
End With
End Sub

复制代码

作业三：用了个笨方法实现循环发贴

经测试，IE6，IE8均成功。

Sub 作业三()
Dim ie
Dim i%
For i = 2 To 4
Set ie = CreateObject("internetexplorer.application")
With ie
.Navigate "http://www.excelpx.com/forum-99-1.html" '打开指定的网页
.Visible = True '显示网页
Do Until .ReadyState = READYSTATE_COMPLETE '如果IE加载宏完成
DoEvents
Loop
With .Document
.getElementById("typeid_fast").Click '点击选择主题分类
.all.tags("li")(1).Click '点击选择文字
.all("subject").Value = Sheets("作业三").Cells(i, 1).Value
.all("message").Value = Sheets("作业三").Cells(i, 2).Value
.forms(2).submit '提交表单
End With
While .ReadyState <> 4 Or .Busy
DoEvents
Wend
.Quit
End With
Set ie = Nothing
Application.Wait (Now + TimeValue("0:00:10")) '间隔10秒后再继续
Next
End Sub

复制代码

一杯清荼 · 发表于 2013-12-11 00:03

本帖最后由一杯清荼于 2013-12-11 00:11 编辑

Sub 作业二()
Dim diqu As New Dictionary, pinzhong As New Dictionary
Dim i As Integer, x As Integer, y As Integer, n As Integer
Dim arr, brr
arr = [a1].CurrentRegion
ReDim brr(1 To UBound(arr), 1 To UBound(arr))
For i = 2 To UBound(arr)
If Not diqu.Exists(arr(i, 2)) Then
diqu(arr(i, 2)) = diqu.Count + 1 '标记地区位置
End If
Next
For i = 1 To 12 '标记每个月品种的位置
pinzhong(i & "月草莓") = pinzhong.Count + 1
pinzhong(i & "月苹果") = pinzhong.Count + 1
pinzhong(i & "月葡萄") = pinzhong.Count + 1
pinzhong(i & "月小计") = pinzhong.Count + 1
Next
pinzhong("合计") = pinzhong.Count + 1
For i = 2 To UBound(arr)
x = diqu(arr(i, 2)) '行的位置
y = pinzhong(Month(arr(i, 1)) & "月" & arr(i, 3)) '列的位置
n = pinzhong(Month(arr(i, 1)) & "月小计") '每月小计的位置
brr(x, y) = brr(x, y) + arr(i, 4) '每月同个地区相同品种的总数量
brr(x, n) = brr(x, n) + arr(i, 4) '每月小计
brr(x, pinzhong("合计")) = brr(x, pinzhong("合计")) + arr(i, 4) '合计
Next
Range("f3").Resize(diqu.Count) = Application.WorksheetFunction.Transpose(diqu.Keys)
Range("g3").Resize(diqu.Count, pinzhong.Count) = brr
End Sub

复制代码

Sub 作业一()
'下棋法
Dim diqu As New Dictionary, pinzhong As New Dictionary
Dim i As Integer, x As Integer, y As Integer
Dim arr, brr
arr = [a1].CurrentRegion
ReDim brr(1 To UBound(arr), 1 To UBound(arr))
For i = 2 To UBound(arr, 1)
If Not diqu.Exists(arr(i, 1)) Then
diqu(arr(i, 1)) = diqu.Count + 1 '标记地区的位置
End If
If Not pinzhong.Exists(arr(i, 2)) Then
pinzhong(arr(i, 2)) = pinzhong.Count + 1 '标记品种的位置
End If
x = diqu(arr(i, 1)) '行的位置
y = pinzhong(arr(i, 2)) '列的位置
brr(x, y) = brr(x, y) + arr(i, 3) '同个地区的同种品种之和
Next i
Range("f2").Resize(diqu.Count) = WorksheetFunction.Transpose(diqu.Keys)
Range("g1").Resize(1, pinzhong.Count) = pinzhong.Keys
Range("g2").Resize(diqu.Count, pinzhong.Count) = brr
End Sub

复制代码

w2001pf · 发表于 2013-12-11 16:23

D05:w2001pf
Option Explicit
Sub 作业1()
Dim d As New Dictionary
Dim d1 As New Dictionary
Dim arr
Dim hs, ls
Dim arr1, j, k, i
With Sheets("作业一")
      arr1 = .Range("a2:c" & Range("a65536").End(xlUp).Row) '把数据源装入数组arr1
      For i = 1 To UBound(arr1) '在数据源中循环，找到所有的品种
         d1(arr1(i, 2)) = ""
      Next i
      .Range("g1").Resize(, d1.Count) = d1.Keys '把品种读入到表格中
      ReDim arr(1 To 20, 1 To d1.Count + 1) '声明一个数组arr，把结果写入到数组arr中
      For j = 1 To UBound(arr1)
         For i = 0 To d1.Count - 1
            If arr1(j, 2) = d1.Keys(i) Then
                  ls = i + 2 '找到汇总的列数，列数用ls表示
            End If
         Next i
         If d.Exists(arr1(j, 1)) Then
            hs = d(arr1(j, 1)) '当关键字存在时，用hs来记录行数，也就是后面用k表示的行数
            arr(hs, ls) = arr(hs, ls) + arr1(j, 3)
         Else
            k = k + 1
            d(arr1(j, 1)) = k '当关键字不存在时，用k表示行数
            arr(k, 1) = arr1(j, 1)
            arr(k, ls) = arr1(j, 3)
         End If
      Next j
      .Range("f2").Resize(k, d1.Count + 1) = arr '把结果读入到表格中
End With
End Sub
Sub 作业2()
Dim i As Long
Dim d1 As New Dictionary
Dim d2 As New Dictionary
Dim arr1, arr2, arr, hs
With Sheets("作业二")
      .Range("F3:BC65536").ClearContents
      arr1 = .Range("a2:d" & Range("a65536").End(xlUp).Row) '把数据源装入数组arr1
      arr2 = .Range("g2:bc2") '把标题行装入数组arr2
      For i = 1 To UBound(arr1)
         If d1.Exists(arr1(i, 2)) = False Then
            d1(arr1(i, 2)) = d1.Count '用字典d1确定结果数组的行数
         End If
      Next i
      For i = 1 To UBound(arr2, 2) - 1
         d2(((i - 1) \ 4 + 1) & "月" & arr2(1, i)) = d2.Count '用字典d2确定结果数组的列数
      Next i
      d2("合计") = i
      ReDim arr(1 To d1.Count, 1 To d2.Count + 1) '声明一个数组arr，把结果写入到数组arr中
      For i = 1 To UBound(arr1)
         arr(d1(arr1(i, 2)) + 1, 1) = arr1(i, 2) '列出各地区名称
         arr(d1(arr1(i, 2)) + 1, d2(Month(arr1(i, 1)) & "月" & arr1(i, 3)) + 2) = arr(d1(arr1(i, 2)) + 1, d2(Month(arr1(i, 1)) & "月" & arr1(i, 3)) + 2) + arr1(i, 4)
         '按地区分月汇总各种水果的数量
         arr(d1(arr1(i, 2)) + 1, d2(Month(arr1(i, 1)) & "月小计") + 2) = arr(d1(arr1(i, 2)) + 1, d2(Month(arr1(i, 1)) & "月小计") + 2) + arr1(i, 4)
         '按地区分月汇总本月所有水果的数量
         arr(d1(arr1(i, 2)) + 1, d2("合计") + 1) = arr(d1(arr1(i, 2)) + 1, d2("合计") + 1) + arr1(i, 4)
         '按地区汇总本地区所有水果的数量
      Next i
      .Range("f3").Resize(d1.Count, d2.Count + 1) = arr '把结果读入到表格中
End With
End Sub

ly258 · 发表于 2013-12-11 17:59

只作了1，2题

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

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

相关帖子

评分

评分

评分

评分

评分