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

cloud-sj · 发表于 2013-11-16 10:49

本帖最后由 as0810114 于 2013-11-23 15:43 编辑

本贴为【VBA字典数组201301班】A组第三讲作业 上交专用，其它学员勿入

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

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

作业上截止时间：2013年11月20日 18：00，原则上在未评分和开贴前上交作业均视为有效

CheryBTL · 发表于 2013-11-16 12:00

Option Explicit
Sub 求不重复值1()
Dim 源数据 '定义源数据
Dim d As New dictionary ' 字典的前期绑定
Dim i As Integer
源数据 = Sheets("求不重复值").Range("A1").CurrentRegion '源数据赋值
For i = 1 To UBound(源数据)
d(源数据(i, 1)) = "" '字典赋值
'或者用以下代码
'If Not d.Exists(源数据(i, 1)) Then d.Add 源数据(i, 1), ""
Next i
Sheets("求不重复值").Range("C2:C65536").ClearContents '清空C列数据
Sheets("求不重复值").[c2].Resize(d.Count) = Application.Transpose(d.Keys) '输出
End Sub
Sub 求不重复值2()
Dim 源数据 '定义源数据
Dim d As New dictionary ' 字典的前期绑定
Dim i As Integer
d.CompareMode = TextCompare '定义比较模式为文本方式
源数据 = Sheets("求不重复值").Range("A1").CurrentRegion '源数据赋值
For i = 1 To UBound(源数据)
d(源数据(i, 1)) = "" '字典赋值
'或者用以下代码
'If Not d.Exists(源数据(i, 1)) Then d.Add 源数据(i, 1), ""
Next i
Sheets("求不重复值").Range("D2:D65536").ClearContents '清空D列数据
Sheets("求不重复值").[D2].Resize(d.Count) = Application.Transpose(d.Keys) '输出
End Sub
Sub 双向求值()
Dim 源数据 '定义源数据
Dim d As New dictionary ' 字典的前期绑定
Dim i As Integer, str As String 'str为待查找数据
Dim 简写 As String
源数据 = Sheets("双向查找").Range("A1").CurrentRegion '源数据赋值
str = Sheets("双向查找").[d3].Value
For i = 2 To UBound(源数据)
d(源数据(i, 1)) = 源数据(i, 2)
d(源数据(i, 2)) = 源数据(i, 1)
Next i
If str > "zz" Then '判断要查询的字符串是英文还是中文
简写 = "对应的简写：" '若为中文时，即str为城市的名称，要查询简写
Else
简写 = "对应的城市：" '若为英文时，即str为城市的简写，要查询名称
End If
MsgBox str & 简写 & d(str), , "城市与简写比向查询"
End Sub
Sub 多条件查找()
Dim 源数据 '定义源数据
Dim d As New dictionary ' 字典的前期绑定
Dim i As Integer, m As Integer, n As Integer
Dim re '存在结果的数据
Dim 条件 '定义条件数据
源数据 = Sheets("多条件查找").Range("A1").CurrentRegion '源数据赋值
条件 = Sheets("多条件查找").Range("A11").CurrentRegion '条件数据赋值
ReDim re(1 To UBound(条件) - 1, 1 To 2)
For i = 2 To UBound(源数据)
If Not d.Exists(源数据(i, 1) & 源数据(i, 2)) Then
m = m + 1
d(源数据(i, 1) & 源数据(i, 2)) = m
End If
Next i
For i = 2 To UBound(条件)
If d.Exists(条件(i, 1) & 条件(i, 2)) Then
n = d(条件(i, 1) & 条件(i, 2))
re(i - 1, 1) = 源数据(n + 1, 3)
re(i - 1, 2) = 源数据(n + 1, 4)
Else
re(i - 1, 1) = "无"
re(i - 1, 2) = "无"
End If
Next i
Sheets("多条件查找").Range("C12:D13").ClearContents '清空E:F二列数据
Sheets("多条件查找").Range("C12:D13") = re '输出字典item值到单元格
End Sub
Sub 单条件求和()
Dim 源数据 '定义源数据
Dim d As New dictionary ' 字典的前期绑定
Dim i As Integer
源数据 = Sheets("单条件求和").Range("A1").CurrentRegion '源数据赋值
For i = 2 To UBound(源数据)
d(源数据(i, 2)) = d(源数据(i, 2)) + 源数据(i, 3) '字典赋值，并将对应的C列值在字典中对应的Item进行相加
Next i
Sheets("单条件求和").Range("E2:F65536").ClearContents '清空E:F二列数据
Sheets("单条件求和").[e2].Resize(d.Count) = Application.Transpose(d.Keys) '输出字典Key值到单元格
Sheets("单条件求和").[f2].Resize(d.Count) = Application.Transpose(d.Items) '输出字典item值到单元格
End Sub
Sub 多列求和()
Dim 源数据 '定义源数据
Dim d As New dictionary ' 字典的前期绑定
Dim i As Integer, m As Integer, n As Integer
Dim re()
源数据 = Sheets("多列求和").Range("A1").CurrentRegion '源数据赋值
For i = 2 To UBound(源数据)
If Not d.Exists(源数据(i, 1)) Then '判断源数据是否已在字典中存在
m = m + 1 '若不存在时，字典的d.count+1(这里是m,也即行标)
d(源数据(i, 1)) = m '将总数值m赋值给对应key的item
ReDim Preserve re(1 To 4, 1 To m) '重定义数组，并对数组进行初始化
re(1, m) = 源数据(i, 1)
End If
n = d(源数据(i, 1)) '得到源数据对应的字典的item(也即行标)
re(2, n) = re(2, n) + 源数据(i, 2) '对数据对应位置进行相加
re(3, n) = re(3, n) + 源数据(i, 3)
re(4, n) = re(4, n) + 源数据(i, 4)
Next i
Sheets("多列求和").Range("A13:D65536").ClearContents '清空A13和D13以下数据
Sheets("多列求和").[a13].Resize(UBound(re, 2), 4) = Application.Transpose(re) '输出
End Sub
Sub 多条件求和()
Dim 源数据 '定义源数据
Dim d As New dictionary ' 字典的前期绑定
Dim i As Integer, m As Integer, n As Integer
Dim re()
源数据 = Sheets("多条件求和").Range("A1").CurrentRegion
For i = 2 To UBound(源数据)
If Not d.Exists(源数据(i, 1) & 源数据(i, 2)) Then '判断源数据是否已在字典中存在
m = m + 1 '若不存在时，字典的d.count+1(这里是m,也即行标)
d(源数据(i, 1) & 源数据(i, 2)) = m '将总数值m赋值给对应key的item
ReDim Preserve re(1 To 3, 1 To m) '重定义数组，并对数组进行初始化
re(1, m) = 源数据(i, 1)
re(2, m) = 源数据(i, 2)
End If
n = d(源数据(i, 1) & 源数据(i, 2)) '得到源数据对应的字典的item(也即行标)
re(3, n) = re(3, n) + 源数据(i, 3) '对数据对应位置进行相加
Next i
Sheets("多条件求和").Range("A11:C65536").ClearContents '清空A13和D13以下数据
Sheets("多条件求和").[a11].Resize(UBound(re, 2), UBound(re)) = Application.Transpose(re) '输出
End Sub

复制代码

qq1194660920 · 发表于 2013-11-17 14:39

{:251:}真的理不清注释怎么写

小小魂 · 发表于 2013-11-17 22:41

交作业了~~~~~~

Option Explicit

Sub 求不重复值1()
Dim d As New Dictionary, arr, rng As Range, i%
arr = Range("a1:a" & Range("a65535").End(3).Row)
Range("c2:d12").ClearContents
For i = 1 To UBound(arr)
      d(arr(i, 1)) = "" '增加不重复的key值，对应的item为空
Next
[c2].Resize(d.Count, 1) = Application.Transpose(d.Keys)
End Sub

Sub 求不重复值2()
Dim d As New Dictionary, arr, rng As Range, i%
arr = Range("a1:a" & Range("a65535").End(3).Row)
Range("c2:d12").ClearContents
d.CompareMode = 1 '区分大小写
For i = 1 To UBound(arr)
      d(arr(i, 1)) = "" '增加不重复的key值，对应的item为空
Next
[d2].Resize(d.Count, 1) = Application.Transpose(d.Keys)
End Sub

Sub 双向求值()
Dim d As New Dictionary, arr, i%
arr = Range("a2:b" & Range("a65535").End(3).Row)
For i = 1 To UBound(arr) * 2 '因为是双向查找，A，B列各增加字典(key\item)位置调换
      If i <= UBound(arr, 1) Then
         d(arr(i, 1)) = arr(i, 2)
      Else
         d(arr(i - UBound(arr), 2)) = arr(i - UBound(arr), 1)
      End If
Next
MsgBox d.Item(Sheets("双向查找").Range("d3").Value) '才学会的，显示Sheets("双向查找").Range("d3").Value为key的item值
End Sub

Sub 多条件查找()
Dim d As New Dictionary, e As New Dictionary
Dim arr, i%, j%
arr = Range("a2:d5")
For i = 1 To 4 '跟函数一样，将不重复值A列B列合并后添加字典，因为数量和单价，故添加了2个字典
      d(arr(i, 1) & arr(i, 2)) = arr(i, 3)
      e(arr(i, 1) & arr(i, 2)) = arr(i, 4)
Next
For j = 1 To 2
      Cells(j + 11, "c") = d.Item(Cells(j + 11, "a") & Cells(j + 11, "b"))
      Cells(j + 11, "d") = e.Item(Cells(j + 11, "a") & Cells(j + 11, "b"))
Next
End Sub

Sub 单条件求和()
Dim d As New Dictionary, i%, arr
arr = Range("b2:c" & Range("a65535").End(3).Row)
Range("e2:f3").ClearContents
For i = 1 To UBound(arr)
      d(arr(i, 1)) = arr(i, 2) + d(arr(i, 1)) '添加字典
Next
[e2].Resize(d.Count, 1) = Application.Transpose(d.Keys)
[f2].Resize(d.Count, 1) = Application.Transpose(d.Items)
End Sub

Sub 多列求和()
Dim d As New Dictionary, e As New Dictionary, f As New Dictionary
Dim arr, i%
arr = Range("a2:d6")
For i = 1 To 5 '因要求数量、单价、金额，添加3个字典
      d(arr(i, 1)) = arr(i, 3)
      e(arr(i, 1)) = e(arr(i, 1)) + arr(i, 2)
      f(arr(i, 1)) = f(arr(i, 1)) + arr(i, 4)
Next
Range("a13").Resize(d.Count, 1) = Application.Transpose(d.Keys)
Range("b13").Resize(d.Count, 1) = Application.Transpose(e.Items)
Range("c13").Resize(d.Count, 1) = Application.Transpose(d.Items)
Range("d13").Resize(d.Count, 1) = Application.Transpose(f.Items)
End Sub

Sub 多条件求和()
Dim d As New Dictionary, e As New Dictionary
Dim arr, i%
arr = Range("a2:c6")
For i = 1 To 5
      d(arr(i, 1) & arr(i, 2)) = d(arr(i, 1) & arr(i, 2)) + arr(i, 3) '跟函数一样，将不重复值A列B列合并后添加字典
      Cells(d.Count + 10, 1) = arr(i, 1)
      Cells(d.Count + 10, 2) = arr(i, 2)
Next

Range("c11").Resize(d.Count, 1) = Application.Transpose(d.Items)
End Sub

木牙水 · 发表于 2013-11-18 09:15

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

午夜洗衣机 · 发表于 2013-11-18 17:01

ID:午夜洗衣机学号:A04

Option Explicit
Sub 求不重复值1()
Dim d As New Dictionary '前期绑定
Dim arr(), k
Dim i As Integer
arr = Sheets("求不重复值").Range("a1").CurrentRegion.Value
For i = 1 To UBound(arr)
d(arr(i, 1)) = i
Next
Cells(2, 3).Resize(d.Count) = Application.Transpose(d.Keys)
End Sub

复制代码

Sub 求不重复值2()
Dim d As New Dictionary
Dim arr(), k, i
arr = Sheets("求不重复值").Range("a1").CurrentRegion.Value
d.CompareMode = TextCompare '进行文本比较,不区分大小写
For Each i In arr
d(i) = i
Next
Cells(2, 4).Resize(d.Count) = Application.Transpose(d.Keys)
End Sub

复制代码

Sub 双向求值()
Dim d, k, i
Dim arr
Dim x As Integer
Set d = CreateObject("scripting.dictionary") '后期绑定
arr = Sheets("双向查找").Range("a2:b6").Value
For x = 1 To UBound(arr)
d(arr(x, 1)) = arr(x, 2) 'keys为城市,items为简写
d(arr(x, 2)) = arr(x, 1) 'keys为简写,items为城市这样就把城市和简写,都写入KEYS了
Next
MsgBox d(Cells(3, 4).Value)
End Sub

复制代码

Sub 多条件查找()
Dim arr, sr, arr1
Dim i As Integer
Dim d As New Dictionary
Dim d1 As New Dictionary
arr = Range("A2:d5").Value
arr1 = Range("a12:d13").Value
For i = 1 To UBound(arr)
sr = arr(i, 1) & "-" & arr(i, 2) '连接AB两列的数值当做keys
d(sr) = arr(i, 3) '数量写入字典1的items
d1(sr) = arr(i, 4) '单价写入字典2的items
Next
For i = 1 To 2
sr = arr1(i, 1) & "-" & arr1(i, 2)
arr1(i, 3) = d(sr) '查找arr1中,在字典1中相应的items
arr1(i, 4) = d1(sr) '查找arr1中,在字典2中相应的items
Next
Cells(12, 3).Resize(2, 1) = Application.Index(arr1, 0, 3) '写入单元格
Cells(12, 4).Resize(2, 1) = Application.Index(arr1, 0, 4)
End Sub

复制代码

Sub 单条件求和()
Dim d As New Dictionary
Dim arr, k
Dim i As Integer
arr = Sheets("单条件求和").Range("B2:C5").Value
For i = 1 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2) '相同关键字,对应的项相加
Next
Cells(2, 5).Resize(d.Count) = Application.Transpose(d.Keys)
Cells(2, 6).Resize(d.Count) = Application.Transpose(d.Items)
End Sub

复制代码

Sub 多列求和()
Dim arr1(1 To 10000, 1 To 4)
Dim n
Dim arr, x As Integer, sr As String, k As Integer
Dim d As New Dictionary
arr = Range("a2:D6").Value
For x = 1 To UBound(arr)
sr = arr(x, 1) & "," & arr(x, 3) '把两个条件连在一起
If d.Exists(sr) Then
n = d(sr) '行数
arr1(n, 2) = arr1(n, 2) + arr(x, 2) '如果条件相同,那么值相加
arr1(n, 4) = arr1(n, 4) + arr(x, 4)
Else '如果keys不存在
k = k + 1
d(sr) = k
arr1(k, 1) = arr(x, 1) '棋盘arr1装入入arr的值
arr1(k, 2) = arr(x, 2)
arr1(k, 3) = arr(x, 3)
arr1(k, 4) = arr(x, 4)
End If
Next x
Range("a13").Resize(k, 4) = arr1
End Sub

复制代码

Sub 多条件求和()
Dim arr1(1 To 10000, 1 To 3)
Dim n
Dim arr, x As Integer, sr As String, k As Integer
Dim d As New Dictionary
arr = Range("a2:c6").Value
For x = 1 To UBound(arr)
sr = arr(x, 1) & "," & arr(x, 2) '把两个条件连在一起
If d.Exists(sr) Then
n = d(sr) '行数
arr1(n, 3) = arr1(n, 3) + arr(x, 3) '如果条件相同,那么值相加
Else '如果keys不存在
k = k + 1
d(sr) = k
arr1(k, 1) = arr(x, 1) '棋盘arr1装入入arr的值
arr1(k, 2) = arr(x, 2)
arr1(k, 3) = arr(x, 3)
End If
Next x
Range("a11").Resize(k, 3) = arr1
End Sub

复制代码

E界白菜 · 发表于 2013-11-19 09:48

这次作业，感觉，还比较容易，做的没有那么的辛苦。
先交上吧。

ldxhzy · 发表于 2013-11-19 16:37

交作业了！

开心妙妙 · 发表于 2013-11-20 10:20

【VBA字典数组201301班】第三讲作业-A03-开心妙妙.rar (97.95 KB, 下载次数: 4)

123小木头人 · 发表于 2013-11-20 17:57

本帖最后由 123小木头人于 2013-11-20 17:58 编辑

Option Explicit
Sub 求不重复值1()
Dim dic As New Dictionary, arr, i%
arr = Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row)
dic.CompareMode = BinaryCompare
For i = LBound(arr) To UBound(arr)
dic(arr(i, 1)) = ""
Next i
Range("c2").Resize(dic.Count).ClearContents
Range("c2").Resize(dic.Count) = Application.WorksheetFunction.Transpose(dic.Keys)
End Sub
Sub 求不重复值2()
Dim dic As New Dictionary, arr, i%
arr = Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row)
dic.CompareMode = TextCompare
For i = LBound(arr) To UBound(arr)
dic(arr(i, 1)) = ""
Next i
Range("d2").Resize(dic.Count).ClearContents
Range("d2").Resize(dic.Count) = Application.WorksheetFunction.Transpose(dic.Keys)
End Sub
Sub 双向求值()
Dim dic As New Dictionary, dic1 As New Dictionary
Dim arr, i%, a As String
a = Cells(3, 4).Value
arr = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
For i = LBound(arr) To UBound(arr)
dic.Item(arr(i, 1)) = arr(i, 2)
dic1.Item(arr(i, 2)) = arr(i, 1)
Next i
If dic.Exists(a) Then
MsgBox dic.Item(a)
Else
MsgBox dic1.Item(a)
End If
End Sub
Sub 多条件查找()
End Sub
Sub 单条件求和()
Dim dic As New Dictionary, arr, i%
arr = Range("a1:c" & Cells(Rows.Count, 1).End(xlUp).Row)
For i = LBound(arr) + 1 To UBound(arr)
If Not dic.Exists(arr(i, 2)) Then
dic(arr(i, 2)) = arr(i, 3)
Else
dic(arr(i, 2)) = arr(i, 3) + dic(arr(i, 2))
End If
Next i
Range("e2").Resize(dic.Count, 2).ClearContents
Range("e2").Resize(dic.Count) = Application.WorksheetFunction.Transpose(dic.Keys)
Range("f2").Resize(dic.Count) = Application.WorksheetFunction.Transpose(dic.Items)
End Sub

复制代码

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

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

点评

评分

点评

评分

评分

点评

评分

点评

评分

评分

点评

评分

评分

A组长:123小木头人这次时间匆忙先交明天早上在补做

点评

评分

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

点评

评分

点评

评分

评分

点评

评分

点评

评分

评分

点评

评分

评分

A组长:123小木头人 这次时间匆忙 先交 明天早上在补做

点评

评分

A组长:123小木头人这次时间匆忙先交明天早上在补做