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

无聊的疯子 · 发表于 2013-11-14 12:04

本帖最后由无聊的疯子于 2013-11-21 17:05 编辑

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

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

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

对于《求不重复值》添加一个附加题
要求：写一个带参数的公用过程来解（根据自己的情况来，凡是正确了的，给经验2点）

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

若因特殊情况，需要申请延后上交的请提前与我联系

xdragon · 发表于 2013-11-14 14:59

本帖最后由 xdragon 于 2013-11-15 14:32 编辑

C08:xdragon
Option Explicit

Sub 求不重复值1()

  Dim arr(), i As Byte

  arr = Range("A1:A12").Value

  With CreateObject("Scripting.Dictionary")

  '利用字典key唯一性原则（默认为区分大小写），将数组依次导入key

For i = 1 To UBound(arr)

   If Not .exists(arr(i, 1)) Then .Add arr(i, 1), ""

Next

'导出字典key中存放的内容到单元格

Range("C2").Resize(.Count) = Application.Transpose(.keys)

  End With

End Sub

Sub 求不重复值2()

'comparemode=1 为不区分大小写，其他同上

  Dim arr(), i As Byte

  arr = Range("A1:A12").Value

  With CreateObject("Scripting.Dictionary")

  .comparemode = 1

For i = 1 To UBound(arr)

   If Not .exists(arr(i, 1)) Then .Add arr(i, 1), ""

Next

Range("D2").Resize(.Count) = Application.Transpose(.keys)

  End With

End Sub

Sub 双向求值()

  Dim arr(), i As Byte, d As Object

  arr = Range("A2:B6").Value

  Set d = CreateObject("scripting.dictionary")

  '循环两次，分别将两列对应的值导入一个字典中，然后根据D3单元格的值在字典查找并返回对应的item

  For i = 1 To UBound(arr)

d(arr(i, 1)) = arr(i, 2)

  Next

  For i = 1 To UBound(arr)

d(arr(i, 2)) = arr(i, 1)

  Next

  MsgBox d([d3].Value), , "查找结果"

End Sub

Sub 多条件查找()

  Dim arr(), brr(), crr(), i As Byte, j As Byte

  arr = Range("A2:D5").Value

  With CreateObject("scripting.dictionary")

For i = 1 To UBound(arr)

   If Not .exists(arr(i, 1) & "|" & arr(i, 2)) Then '将产品和规格合并视为一个字典的key处理

      j = j + 1

      .Item(arr(i, 1) & "|" & arr(i, 2)) = j '当字典中没有新出现的词条时，添加此词条到key，并对此key计数（此计数唯一）

      ReDim Preserve crr(1 To 2, 1 To j)

      crr(1, j) = arr(i, 3): crr(2, j) = arr(i, 4) '将数组中数量和单价分别赋值给crr对应的列中

   End If

Next

brr = Range("A12:B13").Value

ReDim arr(1 To 2, 1 To 2)

'根据查找区域的值查找对应的item，没有找到的显示为“无记录”

For i = 1 To UBound(brr)

   If .exists(brr(i, 1) & "|" & brr(i, 2)) Then

      arr(i, 1) = crr(1, .Item(brr(i, 1) & "|" & brr(i, 2)))

      arr(i, 2) = crr(2, .Item(brr(i, 1) & "|" & brr(i, 2)))

   Else

      arr(i, 1) = "无记录"

      arr(i, 2) = "无记录"

   End If

Next

'导出数组至单元格

Range("C12:D13") = arr

  End With

End Sub

Sub 单条件求和()

  Dim arr(), i As Byte

  arr = Range("A2:C5").Value

  With CreateObject("scripting.dictionary")

  '循环数组，累计相同key对应的item

For i = 1 To UBound(arr)

   .Item(arr(i, 2)) = .Item(arr(i, 2)) + arr(i, 3)

Next

  '结果导出至单元格

[e2].Resize(.Count) = Application.Transpose(.keys)

[f2].Resize(.Count) = Application.Transpose(.items)

  End With

End Sub

Sub 多列求和()

  Dim arr(), brr(), i As Byte, j As Byte

  arr = Range("A2:D6").Value

  With CreateObject("scripting.dictionary")

For i = 1 To UBound(arr)

'i为arr数组行循环计数变量，j为不重复产品的计数变量

   If Not .exists(arr(i, 1)) Then '当arr(i,1)不存在字典中时，添加arr中各字段到brr中

      j = j + 1

      .Item(arr(i, 1)) = j

      ReDim Preserve brr(1 To 4, 1 To j)

      brr(1, j) = arr(i, 1)

      brr(2, j) = arr(i, 2)

      brr(3, j) = arr(i, 3)

      brr(4, j) = arr(i, 4)

   Else '当arr(i,1)存在字典中时，合计第二列和第四列的值，第三列保存为最后一个单价（不知道是不是这题的bug，我觉得应该是我下面注译中的值才对。。。）

      brr(2, .Item(arr(i, 1))) = brr(2, .Item(arr(i, 1))) + arr(i, 2)

      brr(4, .Item(arr(i, 1))) = brr(4, .Item(arr(i, 1))) + arr(i, 4)

      brr(3, .Item(arr(i, 1))) = arr(i, 3)

      'brr(3, .Item(arr(i, 1))) = brr(4, .Item(arr(i, 1))) / brr(2, .Item(arr(i, 1))) '是否应该是平均单价？。。。

   End If

Next

Range("A13").Resize(UBound(brr, 2), 4) = Application.Transpose(brr) '导出数组brr到单元格

  End With

End Sub

Sub 多条件求和()

'这题的方法和上题几乎一模一样。。。不同处下面已标注译

  Dim arr(), brr(), i As Byte, j As Byte

  arr = Range("A2:C6").Value

  With CreateObject("scripting.dictionary")

For i = 1 To UBound(arr)

   If Not .exists(arr(i, 1) & "|" & arr(i, 2)) Then '将产品与规格合并，视为一个字段作为字典的key

      j = j + 1

      .Item(arr(i, 1) & "|" & arr(i, 2)) = j

      ReDim Preserve brr(1 To 3, 1 To j)

      brr(1, j) = arr(i, 1)

      brr(2, j) = arr(i, 2)

      brr(3, j) = arr(i, 3)

   Else

      brr(3, .Item(arr(i, 1) & "|" & arr(i, 2))) = brr(3, .Item(arr(i, 1) & "|" & arr(i, 2))) + arr(i, 3)

   End If

Next

Range("A11").Resize(UBound(brr, 2), 3) = Application.Transpose(brr)

  End With

End Sub
复制代码
通用sub过程
Sub 求不重复值1()

  Call distinct(Range("A1:A12"), Range("C14:C15"))

End Sub

Sub 求不重复值2()

  Call distinct(Range("A1:A12"), Range("D2"), , 1)

End Sub

Sub distinct(RngSource As Range, RngOutput As Range, Optional compare As Byte, Optional ListBy As Byte)

  If ListBy <> 1 And ListBy <> 2 And ListBy <> 0 Then MsgBox "请输入正确的显示方式（1为按列排列，2为按行排列）", , "提示": Exit Sub

  If compare <> 0 And compare <> 1 Then MsgBox "请输入正确的比较方式（1为不区分大小写，0为区分大小写）", , "提示": Exit Sub

  Dim arr(), ar

  arr = RngSource.Value

  With CreateObject("Scripting.Dictionary")

.comparemode = compare

For Each ar In arr

   If Not .exists(ar) Then .Item(ar) = ""

Next

  RngOutput.Resize(IIf(ListBy = 1 Or ListBy = 0, .Count, 1), IIf(ListBy = 2, .Count, 1)) = IIf(ListBy = 2, .keys, Application.Transpose(.keys))

  End With

End Sub

复制代码

hoogle · 发表于 2013-11-14 22:03

Option Explicit
Sub 求不重复值1()
Dim arrData, arrRes, i, d
With Sheets("求不重复值")
arrData = .Range("a1").CurrentRegion
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(arrData)
d(arrData(i, 1)) = ""
Next
arrRes = d.keys
.Range("c2").Resize(UBound(arrRes), 1).ClearContents
.Range("c2").Resize(UBound(arrRes) + 1, 1) = Application.Transpose(arrRes)
End With
End Sub
Sub 求不重复值2()
Dim arrData, arrRes, i, d
With Sheets("求不重复值")
arrData = .Range("a1").CurrentRegion
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(arrData)
If Not d.exists(UCase(arrData(i, 1))) Then d(arrData(i, 1)) = ""
Next
arrRes = d.keys
.Range("d2").Resize(UBound(arrRes), 1).ClearContents
.Range("d2").Resize(UBound(arrRes) + 1, 1) = Application.Transpose(arrRes)
End With
End Sub
Sub 双向求值()
Dim arrData, i, d
Set d = CreateObject("scripting.dictionary")
arrData = Sheets("双向查找").Range("a1").CurrentRegion
For i = 1 To UBound(arrData)
d(arrData(i, 1)) = arrData(i, 2)
d(arrData(i, 2)) = arrData(i, 1)
Next
MsgBox d(Sheets("双向查找").Range("d3").Value)
End Sub
Sub 多条件查找()
Dim arrData, arrRes, i, d
Set d = CreateObject("scripting.dictionary")
With Sheets("多条件查找")
.Range("c12:D13").ClearContents
arrRes = .Range("a12:d13")
arrData = .Range("a1").CurrentRegion
For i = 2 To UBound(arrData)
d(arrData(i, 1) & "|" & arrData(i, 2)) = CStr(arrData(i, 3)) & "|" & CStr(arrData(i, 4))
Next
For i = 1 To 2
If d.exists(arrRes(i, 1) & "|" & arrRes(i, 2)) Then
arrRes(i, 3) = Split(d(arrRes(i, 1) & "|" & arrRes(i, 2)), "|")(0)
arrRes(i, 4) = Split(d(arrRes(i, 1) & "|" & arrRes(i, 2)), "|")(1)
End If
Next
.Range("a12").Resize(UBound(arrRes), UBound(arrRes, 2)) = arrRes
End With
End Sub
Sub 单条件求和()
Dim arrData, i, d, arrRes(1 To 2)
arrData = Sheets("单条件求和").Range("a1").CurrentRegion.Offset(1)
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(arrData) - 1
d(arrData(i, 2)) = arrData(i, 3) + d(arrData(i, 2))
Next
arrRes(1) = d.keys
arrRes(2) = d.items
Sheets("单条件求和").Range("e2").Resize(UBound(arrRes(1)) + 1, 1) = Application.Transpose(arrRes(1))
Sheets("单条件求和").Range("f2").Resize(UBound(arrRes(2)) + 1, 1) = Application.Transpose(arrRes(2))
End Sub
Sub 多列求和()
Dim arrData, i, arrRes(1 To 2, 1 To 4), d
With Sheets("多列求和")
arrData = .Range("a1").CurrentRegion
Set d = CreateObject("scripting.dictionary")
For i = 2 To UBound(arrData)
If Not d.exists(arrData(i, 1)) Then
d(arrData(i, 1)) = d.Count + 1
End If
arrRes(d(arrData(i, 1)), 1) = arrData(i, 1)
arrRes(d(arrData(i, 1)), 2) = arrRes(d(arrData(i, 1)), 2) + arrData(i, 2)
arrRes(d(arrData(i, 1)), 3) = arrData(i, 3)
arrRes(d(arrData(i, 1)), 4) = arrRes(d(arrData(i, 1)), 4) + arrData(i, 4)
Next
.Range("A13").Resize(2, 4) = arrRes
End With
End Sub
Sub 多条件求和()
Dim arrData, arrRes(), i, d
With Sheets("多条件求和")
arrData = .Range("a1").CurrentRegion
ReDim arrRes(1 To UBound(arrData), 1 To UBound(arrData, 2))
Set d = CreateObject("scripting.dictionary")
For i = 2 To UBound(arrData)
If Not d.exists(arrData(i, 1) & "|" & arrData(i, 2)) Then
d(arrData(i, 1) & "|" & arrData(i, 2)) = d.Count + 1
arrRes(d.Count, 1) = arrData(i, 1)
arrRes(d.Count, 2) = arrData(i, 2)
arrRes(d.Count, 3) = arrData(i, 3)
Else
arrRes(d(arrData(i, 1) & "|" & arrData(i, 2)), 3) = arrRes(d(arrData(i, 1) & "|" & arrData(i, 2)), 3) + arrData(i, 3)
End If
Next
.Range("a11").Resize(UBound(arrData), UBound(arrData, 2)) = arrRes
End With
End Sub

复制代码

hrpotter · 发表于 2013-11-15 09:22

本帖最后由 hrpotter 于 2013-11-15 13:05 编辑

Option Explicit
Sub 求不重复值1()
Dim arr, brr
arr = Range("a1").CurrentRegion '将待处理数据放入数组
求不重复值 arr, brr '调用过程求不重复值，第三参数省略，区分大小写
Range("c2:c12").ClearContents
Range("c2").Resize(UBound(brr)) = brr
End Sub
Sub 求不重复值2()
Dim arr, brr
arr = Range("a1").CurrentRegion '将待处理数据放入数组
求不重复值 arr, brr, False '调用过程求不重复值，第三参数false，不区分大小写
Range("d2:d12").ClearContents
Range("d2").Resize(UBound(brr)) = brr
End Sub
Sub 求不重复值(arr As Variant, brr As Variant, Optional cm As Boolean = True)
'第一参数为源数据，第二参数为结果数组，第三参数为是否区分大小写，默认为true
Dim d As Object, i As Long, j As Long
Set d = CreateObject("scripting.dictionary") '创建字典
If cm = False Then '如果第三参数为false
d.comparemode = vbTextCompare '使用文本比较，不区分大小写
End If
If IsArray(arr) Then '如果源数据为数组
For i = 1 To UBound(arr) '循环数组添加字典
For j = 1 To UBound(arr, 2)
d(arr(i, j)) = ""
Next
Next
Else '如果源数据不为数组
d(arr) = "" '直接添加字典
End If
brr = Application.Transpose(d.keys) '将字典关键字转化为数组输出
End Sub
Sub 双向求值()
Dim arr, d
Dim i As Long
Set d = CreateObject("scripting.dictionary")
arr = Range("a1").CurrentRegion
For i = 2 To UBound(arr)
d(arr(i, 1)) = arr(i, 2) '将城市名放入key,简写放入item
d(arr(i, 2)) = arr(i, 1) '将简写放入key,城市名放入item
Next
MsgBox d(Range("d3").Value)
End Sub
Sub 多条件查找()
Dim arr, d, brr(1 To 2, 1 To 2)
Dim i As Long
Set d = CreateObject("scripting.dictionary") '创建字典
arr = Range("a1").CurrentRegion
For i = 2 To UBound(arr)
d(arr(i, 1) & "|" & arr(i, 2)) = arr(i, 3) & "|" & arr(i, 4)
'将产品和规格以“|”连接放入key,将数量和单价以"|"连接放入item
Next
arr = Range("a12:b13")
For i = 1 To 2
brr(i, 1) = Split(d(arr(i, 1) & "|" & arr(i, 2)), "|")(0) '取出对应产品和规格的对应的数量
brr(i, 2) = Split(d(arr(i, 1) & "|" & arr(i, 2)), "|")(1) '出出对应产品和规格的对应的单价
Next
Range("c12").Resize(2, 2) = brr
End Sub
Sub 单条件求和()
Dim arr, d
Dim i As Long
Set d = CreateObject("scripting.dictionary") '创建字典
arr = Range("a1").CurrentRegion
For i = 2 To UBound(arr)
d(arr(i, 2)) = d(arr(i, 2)) + arr(i, 3) '循环数组，相同产品名的，数量累加
Next
Range("e2:f1000").ClearContents
Range("e2").Resize(d.Count) = Application.Transpose(d.keys) '将产品名写入
Range("f2").Resize(d.Count) = Application.Transpose(d.items) '将对应的汇总数量写入
End Sub
Sub 多列求和()
Dim arr, d, brr(1 To 100, 1 To 4)
Dim i As Long, j As Long, k As Long, n As Long
Set d = CreateObject("scripting.dictionary") '创建字典
arr = Range("a1").CurrentRegion
For i = 2 To UBound(arr)
If d.exists(arr(i, 1)) Then '如果产品在字典中存在
j = d(arr(i, 1)) '取出产品在字典中对应的数字即结果数组中的对应行
brr(j, 2) = brr(j, 2) + arr(i, 2) '结果数组中对应的累计数量加源数据数组中的数量
brr(j, 3) = arr(i, 3) '结果数组中对应的单价等于源数据数组中的单价
brr(j, 4) = brr(j, 4) + arr(i, 4) '结果数组中对应的累计金额加源数据数组中的金额
Else '如果该产品在字典中不存在
k = k + 1 '字典key增加一条
d(arr(i, 1)) = k '以产品为key,字典的条目数量为item增加一条
For n = 1 To 4 '循环将源数据数组产品数量单价金额依次赋入结果数组
brr(k, n) = arr(i, n)
Next
End If
Next
Range("a13:d100").ClearContents
Range("a13").Resize(k, 4) = brr '赋值
End Sub
Sub 多条件求和()
Dim d, arr, brr(1 To 100, 1 To 3)
Dim i As Long, j As Long, k As Long, n As Long, s As String
Set d = CreateObject("scripting.dictionary") '创建字典
arr = Range("a1").CurrentRegion
For i = 2 To UBound(arr)
s = arr(i, 1) & "|" & arr(i, 2) '将产品和规格用"|"连接放放字符串s中
If d.exists(s) Then '如果以s为key在字典中存在
j = d(s) '取出s为key对应的item即结果数组中的行数
brr(j, 3) = brr(j, 3) + arr(i, 3) '结果数组对应的数量累加当前数组中对应的数量
Else '如果不存在，计数累加，字典中增加一条新的key
k = k + 1
d(arr(i, 1) & "|" & arr(i, 2)) = k
For n = 1 To 3 '将源数据数组中的数据赋值给结果数组
brr(k, n) = arr(i, n)
Next
End If
Next
Range("a11:c20").ClearContents
Range("a11").Resize(k, 3) = brr '赋值
End Sub

复制代码

sayloveyou2010 · 发表于 2013-11-16 09:37

本帖最后由 sayloveyou2010 于 2013-11-17 00:18 编辑

字典数组班C01:小妮子

'第一题：
Sub 求不重复值1()
Dim dic As New Dictionary, arr(), x%
arr = Range("A1:A" & Cells(Rows.Count, 1).End(3).Row) '把数据装入数组
dic.CompareMode = 0 '区分大小写
For x = 1 To UBound(arr)
If Not dic.Exists(arr(x, 1)) Then '如果不存在
dic.Add arr(x, 1), "" '将关键字添加到字典
End If
Next x
[C2].Resize(dic.Count, 1) = Application.Transpose(dic.Keys) '读出
Set dic = Nothing
Erase arr
End Sub
Sub 求不重复值2()
Dim dic As New Dictionary, arr(), x%
arr = Range("A1:A" & Cells(Rows.Count, 1).End(3).Row) '把数据装入数组
dic.CompareMode = 1 '不区分大小写
For x = 1 To UBound(arr)
If Not dic.Exists(arr(x, 1)) Then '如果不存在
dic.Add arr(x, 1), "" '将关键字添加到字典
End If
Next x
[d2].Resize(dic.Count, 1) = Application.Transpose(dic.Keys) '读出
Set dic = Nothing
Erase arr
End Sub
Sub 附加题()
Dim rgSource As Range
Dim rgDest As Range
Dim bMold
On Error Resume Next
Set rgSource = Application.InputBox("请选择需要分组的单元格区域", "选择", Type:=8)
'通过对话框选择要去重的单元格区域
If rgSource Is Nothing Then
MsgBox "没有选择要去重的单元格区域"
Exit Sub
End If
Set rgDest = Application.InputBox("请选择去重数据写入的位置", "选择", Type:=8)
'通过对话框选择分组后的数据需写入的单元格
If rgDest Is Nothing Then
MsgBox "没有选择要去重的单元格区域"
Exit Sub
End If
bMold = Application.InputBox("请输入要去重的类型，0区分大小写，1不区分大小写)", "选择", Default:=0, Type:=2)
'通过对话框输入是否区分大小写
If Val(bMold) > 1 Or Val(bMold) < 0 Then
' 检测行数的合法性
MsgBox prompt:="输入的类型不对" & String(2, vbCrLf) & "请输入有效数字", Title:="错误提示"
Exit Sub
End If
Call 去重(rgSource, rgDest, Val(bMold))
'调用分组过程
End Sub
Sub 去重(rgSource As Range, rgDest As Range, bMold As Byte)
Dim dic As New Dictionary, arr(), x%, y%
arr = rgSource.Value '将选区数据装入数组arr
If bMold = 0 Then
dic.CompareMode = 0 '区分大小写
Else
dic.CompareMode = 1 '不区分大小写
End If
For x = 1 To UBound(arr)
For y = 1 To UBound(arr, 2)
If Not dic.Exists(arr(x, y)) Then '如果不存在
dic.Add arr(x, y), "" '将关键字添加到字典
End If
Next y
Next x
rgDest.Resize(dic.Count, 1) = Application.Transpose(dic.Keys) '读出
Set dic = Nothing
Erase arr
End Sub
'第二题：
Sub 双向求值()
Dim dic As New Dictionary, arr(), x%, x1%, Mys$
arr = Range("A1:B" & Cells(Rows.Count, 1).End(3).Row) '把数据装入数组
Mys = [d3]
If Left(Mys, 1) Like "[a-z]" Then '判断是否字母
For x = 1 To UBound(arr)
dic.Add arr(x, 2), arr(x, 1) '添加字典
Next x
ElseIf Not (IsNumeric(Left(Mys, 1))) Then '判断是否汉字
For x = 1 To UBound(arr)
dic.Add arr(x, 1), arr(x, 2) '添加字典
Next x
End If
arr = Range("d3:e3")
arr(1, 2) = dic.Item(arr(1, 1)) '查找
[d3].Resize(1, 2) = arr '读出
Set dic = Nothing
Erase arr
End Sub
'第三题：
Sub 多条件查找()
Dim dic As New Dictionary, arr(), brr(), x%, y%, m$, n$
arr = Range("A2:d5")
brr = Range("A12:D13")
For x = 1 To UBound(arr)
m = arr(x, 1) & vbTab & arr(x, 2) '条件key连接
n = arr(x, 3) & "/" & arr(x, 4) 'item连接
dic.Add m, n '增加字典
Next x
For x = 1 To UBound(brr)
m = brr(x, 1) & vbTab & brr(x, 2) '结果数组里的key连接
If dic.Exists(m) Then '甉在字典中是否存在
brr(x, 3) = Split(dic.Item(m), "/")(0) '取值
brr(x, 4) = Split(dic.Item(m), "/")(1) '取值
Else
MsgBox "未找到相关内容"
End If
Next x
[A12].Resize(2, 4) = brr
Erase arr, brr
Set dic = Nothing
End Sub
'第四题：
Sub 单条件求和()
Dim dic As New Dictionary, arr(), brr(), x%, k%, y%
arr = Range("A2:C" & Cells(Rows.Count, 1).End(3).Row) '把数据装入数组
ReDim brr(1 To UBound(arr), 1 To 2) '重新定义结果数组
For x = 1 To UBound(arr)
If dic.Exists(arr(x, 2)) Then '判断是否存在，如果存在
brr(dic(arr(x, 2)), 2) = brr(dic(arr(x, 2)), 2) + arr(x, 3) '累加数量
Else
k = k + 1 '计数器
dic.Add arr(x, 2), k '添加
brr(k, 1) = arr(x, 2) '产品
brr(k, 2) = arr(x, 3) '数量
End If
Next x
[E2].Resize(k, 2) = brr '读出
Erase arr, brr
Set dic = Nothing
End Sub
'第五题：
Sub 多列求和()
Dim dic As New Dictionary, arr(), brr(), x%, m$, k%, y%
arr = Range("A2:D6")
ReDim brr(1 To UBound(arr), 1 To 4)
For x = 1 To UBound(arr)
If Not dic.Exists(arr(x, 1)) Then '判断是否存在
k = k + 1 '计数器
dic.Add arr(x, 1), k '增加字典
For y = 1 To UBound(brr, 2)
brr(k, y) = arr(x, y) '相关内容写入结果数组
Next y
Else '已存在则
For y = 2 To UBound(brr, 2)
brr(dic(arr(x, 1)), y) = brr(dic(arr(x, 1)), y) + arr(x, y) '累加
Next y
End If
Next x
For x = 1 To UBound(arr)
brr(dic(arr(x, 1)), 3) = arr(x, 3) '修改单价
Next x
[A13].Resize(UBound(brr), 4) = brr '读出
Erase arr, brr
Set dic = Nothing
End Sub
'第六题：
Sub 多条件求和()
Dim dic As New Dictionary, arr(), x%, m$, k%
arr = Range("A2:C6")
ReDim brr(1 To UBound(arr), 1 To 3)
For x = 1 To UBound(arr)
m = arr(x, 1) & vbTab & arr(x, 2) '连接条件key
If Not dic.Exists(m) Then '判断是否存在
k = k + 1
dic.Add m, k '添加字典
brr(x, 1) = Split(m, vbTab)(0) '产品
brr(x, 2) = Split(m, vbTab)(1)
brr(x, 3) = brr(x, 3) + arr(x, 3) '规格
Else
brr(dic.Item(m), 3) = brr(dic.Item(m), 3) + arr(x, 3) '累加数量
End If
Next x
[A11].Resize(UBound(brr), 3) = brr '读出
Erase arr, brr
Set dic = Nothing
End Sub

复制代码

箫风 · 发表于 2013-11-16 10:59

本帖最后由箫风于 2013-11-16 19:22 编辑

C05：箫风

Sub 求不重复值1()
不重复值 0, "C"
End Sub
Sub 求不重复值2()
不重复值 1, "D"
End Sub
'通过设置字典的比较模式参数实现区分大小写和不区分大小写，设置列参数以将不同的去重方式放入相应的位置
Sub 不重复值(dm As Integer, rg As String)
Dim arr()
Dim i As Integer
Dim d As New Dictionary
d.CompareMode = dm
Range(rg & "2" & ":" & rg & 100).ClearContents
arr = Range("A1:A12").Value
For i = LBound(arr) To UBound(arr)
d(arr(i, 1)) = ""
Next i
Range(rg & "2").Resize(d.Count) = Application.WorksheetFunction.Transpose(d.Keys)
End Sub
Sub 双向求值()
Dim arr()
Dim i As Integer
Dim d1 As New Dictionary
Dim d2 As New Dictionary
arr = Range("A2:B6").Value
'将城市、简写和简写、城市分别放入不同的字典以实现双向查找
For i = LBound(arr) To UBound(arr)
d1(arr(i, 1)) = arr(i, 2)
d2(arr(i, 2)) = arr(i, 1)
Next i
'通过判断要查找的内容是城市名称还是拼音简写实现不同的查找
If VBA.Asc(Range("D3")) >= 65 And VBA.Asc(Range("D3")) <= 122 Then
MsgBox d2.Item(Range("D3").Value)
Else
MsgBox d1.Item(Range("D3").Value)
End If
End Sub
Sub 单条件求和()
Dim arr()
Dim i As Integer, j As Integer
Dim d As New Dictionary
Range("E2:F3").ClearContents
arr = Range("B2:C5").Value
'将产品名称放入字典以剔除重复的产品名称
For i = LBound(arr) To UBound(arr)
d(arr(i, 1)) = ""
Next i
ReDim arr2(d.Count - 1)
'通过两层循环，将数据源中的数量汇总至同类的产品名称中
For i = 0 To d.Count - 1
For j = LBound(arr) To UBound(arr)
If arr(j, 1) = d.Keys(i) Then
arr2(i) = arr2(i) + arr(j, 2)
End If
Next j
Next i
Range("E2").Resize(d.Count) = Application.WorksheetFunction.Transpose(d.Keys)
Range("F2").Resize(d.Count) = Application.WorksheetFunction.Transpose(arr2)
End Sub
Sub 多条件查找()
Dim i As Integer
Dim arr1
Dim d1 As New Dictionary
Dim d2 As New Dictionary
Range("C12:D100").ClearContents
arr1 = Range("A2:D5")
'将产品和规格连成一个字符串放入字典以剔除重复的产品和规格
For i = LBound(arr1, 1) To UBound(arr1, 1)
d1.Add arr1(i, 1) & arr1(i, 2), arr1(i, 3)
d2.Add arr1(i, 1) & arr1(i, 2), arr1(i, 4)
Next i
'在数据源中查找相应的产品和规格的数量和单价
For i = 1 To 2
Range("C" & i + 11) = d1(Range("A" & i + 11).Value & Range("B" & i + 11).Value)
Range("D" & i + 11) = d2(Range("A" & i + 11).Value & Range("B" & i + 11).Value)
Next i
End Sub
Sub 多列求和()
Dim arr()
Dim i As Integer, j As Integer
Dim d As New Dictionary
Range("A13:D100").ClearContents
arr = Range("A2:D6").Value
'将产品名称放入字典以剔除重复的产品名称
For i = LBound(arr) To UBound(arr)
d(arr(i, 1)) = ""
Next i
ReDim arr1(1 To d.Count, 1 To 4)
'通过两层循环，将数据源中的数量、单价和金额汇总至同类的产品名称中
For i = 1 To d.Count
For j = LBound(arr, 1) To UBound(arr, 1)
arr1(i, 1) = d.Keys(i - 1)
If arr(j, 1) = d.Keys(i - 1) Then
arr1(i, 2) = arr1(i, 2) + arr(j, 2)
arr1(i, 3) = arr(j, 3)
arr1(i, 4) = arr1(i, 4) + arr(j, 4)
End If
Next j
Next i
Range("A13").Resize(d.Count, 4) = arr1
End Sub
Sub 多条件求和()
Dim i As Integer, j As Integer
Dim arr1
Dim d As New Dictionary
Range("A11:C100").ClearContents
arr1 = Range("A2:C6")
'将产品和规格连成一个字符串放入字典以剔除重复的产品和规格
For i = LBound(arr1, 1) To UBound(arr1, 1)
d(arr1(i, 1) & arr1(i, 2)) = ""
Next i
ReDim arr2(1 To d.Count, 1 To 3)
'通过两层循环，将数据源中的数量累加至同类的产品和规格中
For i = 1 To d.Count
For j = LBound(arr1, 1) To UBound(arr1, 1)
arr2(i, 1) = VBA.Left(d.Keys(i - 1), 1)
arr2(i, 2) = VBA.Right(d.Keys(i - 1), 2)
If arr1(j, 1) & arr1(j, 2) = d.Keys(i - 1) Then
arr2(i, 3) = arr2(i, 3) + arr1(j, 3)
End If
Next j
Next i
Range("A11").Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
End Sub

复制代码

笨熊猫 · 发表于 2013-11-17 00:43

……

monicaj · 发表于 2013-11-17 00:56

c02：monicaj
Option Explicit

Sub 求不重复值1()
Dim arr '用于存放源数据
Dim i As Integer

Dim d As New Dictionary
d.CompareMode = BinaryCompare '设置为区分大小写

arr = Range("a1:a12")
For i = 1 To UBound(arr)

      d(arr(i, 1)) = "" '将源数据存入字典，重复的自动覆盖
Next
Range("c2").Resize(d.Count) = Application.Transpose(d.Keys)

End Sub

Sub 求不重复值2()
Dim arr '用于存放源数据
Dim i As Integer

Dim d As New Dictionary
d.CompareMode = TextCompare '设置为不区分大小写

arr = Range("a1:a12")
For i = 1 To UBound(arr)

      d(arr(i, 1)) = "" '将源数据存入字典，重复的自动覆盖
Next
Range("d2").Resize(d.Count) = Application.Transpose(d.Keys)

End Sub

Sub 双向求值()
Dim arr '用于存放源数据
Dim i As Integer

Dim d As New Dictionary

arr = Range("a2:b6")
For i = 1 To UBound(arr)

      d(arr(i, 1)) = arr(i, 2) '将两列源数据分别存入字典，重复的自动覆盖

      d(arr(i, 2)) = arr(i, 1)
Next
MsgBox d(Range("d3").Value)

End Sub

Sub 多条件查找()
Dim arr '用于存放源数据
Dim i As Integer
Dim str1 As String  '用于将结果第一行产品和规格连接起来，统一查找
Dim str2 As String '用于将结果第二行产品和规格连接起来，统一查找
Dim str As String '用于将源数据产品和规格连接起来，统一查找

Dim d1 As New Dictionary '用于存放数量列
Dim d2 As New Dictionary '用于存放单价列

arr = Range("a2:d5")
For i = 1 To UBound(arr)

      str = arr(i, 1) & "-" & arr(i, 2)
      d1(str) = arr(i, 3) '将产品规格连接作为key，item存放数量列
      d2(str) = arr(i, 4)    '将产品规格连接作为key，item存放单价列

Next
str1 = Range("a12") & "-" & Range("b12") '将产品规格连接起来查找
str2 = Range("a13") & "-" & Range("b13")

If d1.Exists(str1) Then

      Range("c12") = d1(str1)
      Range("d12") = d2(str1)
Else

      Range("c12") = 0 '如果是不存在的产品、规格组合，设定数量、单价为0

      Range("d12") = 0
End If

If d1.Exists(str2) Then

      Range("c13") = d1(str2)
      Range("d13") = d2(str2)
Else

      Range("c13") = 0
      Range("d13") = 0
End If

End Sub

Sub 单条件求和()
Dim arr '用于存放源数据
Dim i As Integer

Dim d As New Dictionary

arr = Range("b2:c5")
For i = 1 To UBound(arr)

      d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2) '将两列源数据分别存入字典，字典的item值是在原基础上加新的数量

Next
Range("e2").Resize(d.Count) = Application.Transpose(d.Keys)
Range("f2").Resize(d.Count) = Application.Transpose(d.Items)

End Sub

Sub 多列求和()
Dim arr '用于存放源数据
Dim i As Integer
Dim k As Integer    '用于某产品首次出现在结果数组中的计数
Dim brr(1 To 10, 1 To 4) '用于存放结果数据
Dim line As Integer    '用于记录某产品在结果数组中的行数

Dim d As New Dictionary

arr = Range("a2:d6")

For i = 1 To UBound(arr)
      If d.Exists(arr(i, 1)) = False Then '如果某产品不存在于字典中

         k = k + 1    '计数器加1，作为在brr中的行数
         d(arr(i, 1)) = k '将产品名称作为key，将其在brr中的行数计入字典的item

         brr(k, 1) = arr(i, 1) '将该行数据计入结果数组中

         brr(k, 2) = arr(i, 2)

         brr(k, 4) = arr(i, 4)
         brr(k, 3) = arr(i, 4) / arr(i, 2)
      Else '如果某产品已经存在于字典中

         line = d(arr(i, 1)) '读取在结果数组中的行数
         brr(line, 2) = brr(line, 2) + arr(i, 2) '以下三行，将现有的数量、金额加到在结果数组中的所在行，计算单价

         brr(line, 4) = brr(line, 4) + arr(i, 4)

         brr(line, 3) = brr(line, 4) / brr(line, 2)
      End If

Next
Range("a13").Resize(UBound(brr), 4) = brr

End Sub

Sub 多条件求和()
Dim arr '用于存放源数据
Dim i As Integer
Dim str As String
Dim k As Integer '用于某产品首次出现在结果数组中的计数
Dim line As Integer    '用于记录某产品在结果数组中的行数

Dim brr(1 To 10, 1 To 3) '用于存放结果数据

Dim d As New Dictionary

arr = Range("a2:c6")
For i = 1 To UBound(arr)

      str = arr(i, 1) & "-" & arr(i, 2) '用于将产品和规格连接起来，统一查找

      If d.Exists(str) = False Then '如果某产品不存在于字典中
         k = k + 1    '计数器加1，作为在brr中的行数

         d(str) = k '将产品名称和规格作为key，将其在brr中的行数计入字典的item
         brr(k, 1) = arr(i, 1) '将该行数据计入结果数组中
         brr(k, 2) = arr(i, 2)
         brr(k, 3) = arr(i, 3)
      Else
         line = d(str) '读取在结果数组中的行数
         brr(line, 3) = brr(line, 3) + arr(i, 3) '将现有的数量加到在结果数组中的所在行

      End If
      Range("a11").Resize(UBound(brr), 3) = brr

Next

End Sub

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

本帖最后由 cxloen 于 2013-11-17 16:11 编辑

{:011:}

Sellby · 发表于 2013-11-17 16:46

Option Explicit
Sub 求不重复值1()
Dim arr, s
Dim d As New Dictionary '定义一个字典对象
arr = Range("a1").CurrentRegion.Value '将数据源赋给一个数组
For Each s In arr '遍历数组
If Not d.Exists(s) Then d.Add s, "" '判断每一数组元素是否已在字典对象中，如果没有，则增加到字典中
Next
Range("c2").Resize(10000).ClearComments '清空指定单元格区域内容
Range("c2").Resize(d.Count) = Application.Transpose(d.Keys) '将字典的关键字放入指定单元格
Set d = Nothing '释放字典对象
End Sub
Sub 求不重复值2()
Dim arr, s
Dim d As New Dictionary '定义一个字典对象
d.CompareMode = TextCompare '字典对象的字符串比较模式为文本比较,即不区分大小写
arr = Range("a1").CurrentRegion.Value '将数据源赋给一个数组
For Each s In arr '遍历数组
If Not d.Exists(s) Then d.Add s, "" '判断每一数组元素是否已在字典对象中，如果没有，则增加到字典中
Next
Range("d2").Resize(10000).ClearComments '清空指定单元格区域内容
Range("d2").Resize(d.Count) = Application.Transpose(d.Keys) '将字典的关键字放入指定单元格
Set d = Nothing '释放字典对象
End Sub
Sub 双向求值()
Dim arr, s$, i%
Dim d As New Dictionary '定义一个字典对象
arr = Range("a1").CurrentRegion.Value '将数据源赋给一个数组
s = Range("d3").Value '将查询的内容赋给变量
For i = 1 To UBound(arr) '对数组进行循环
d.Add arr(i, 1), arr(i, 2) '将城市作关键字，简写作为项目，增加到字典中
d.Add arr(i, 2), arr(i, 1) '将项目作关键字，城市作项目，增加到字典中
Next i
MsgBox s & "对应的" & IIf(s > d.Item(s), "简写是：", "城市：") & d.Item(s) '消息框显示结果
Set d = Nothing '释放字典对象
End Sub
Sub 多条件查找()
Dim arr, i%, s1$, s2$
Dim d As New Dictionary '定义一个字典对象
arr = Range("a1").CurrentRegion.Value '将数据源赋给一个数组
For i = 2 To UBound(arr) '对数组进行循环
d(arr(i, 1) & "|" & arr(i, 2)) = Array(arr(i, 3), arr(i, 4)) '将产品结合规格作关键字，数量和单价的数组作业项目，增加到字典中
Next i
s1 = Range("a12") & "|" & Range("b12") '将查找的产品规格赋给一个变量
s2 = Range("a13") & "|" & Range("b13")
Range("c12:d13").ClearContents '清空指定单元格区域内容
If d.Exists(s1) Then Range("c12:d12") = d.Item(s1) '将字典的项目放入指定单元格
If d.Exists(s2) Then Range("c13:d13") = d.Item(s2)
Set d = Nothing '释放字典对象
End Sub
Sub 单条件求和()
Dim arr, i%
Dim d As New Dictionary '定义一个字典对象
arr = Range("a1").CurrentRegion.Value '将数据源赋给一个数组
For i = 2 To UBound(arr) '对数组进行循环
d(arr(i, 2)) = d(arr(i, 2)) + arr(i, 3) '将产品作关键字，数量作项目，增加到字典中，并进行累计求和
Next i
Range("e2:d1000").ClearContents '清空指定单元格区域内容
Range("e2").Resize(d.Count) = Application.Transpose(d.Keys) '将字典的关键字放入指定单元格
Range("f2").Resize(d.Count) = Application.Transpose(d.Items) '将字典的项目放入指定单元格
Set d = Nothing '释放字典对象
End Sub
Sub 多列求和()
Dim arr, brr, temparr, i%
Dim d As New Dictionary '定义一个字典对象
arr = Range("a1").CurrentRegion.Value '将数据源赋给一个数组
For i = 2 To UBound(arr) '对数组进行循环
If d.Exists(arr(i, 1)) Then '如果关键字已经存在
temparr = d(arr(i, 1)) '将关键字对应的项目赋给一个临时数组
temparr(0) = temparr(0) + arr(i, 2) '将临时数组中的数量加上新的数量
temparr(2) = temparr(2) + arr(i, 4) '将临时数组中的金额加上新的金额
d(arr(i, 1)) = temparr '将关键字对应的项目变更为新的临时数组，实现累计求和的要求
Else '如果关键字不存在
d(arr(i, 1)) = Array(arr(i, 2), arr(i, 3), arr(i, 4)) '将产品作关键字，数量/单价/金额作项目，增加到字典中
End If
Next i
Range("a13:d1000").ClearContents '清空指定单元格区域内容
Range("a13").Resize(d.Count) = Application.Transpose(d.Keys) '将字典的关键字放入指定单元格
Range("b13").Resize(d.Count, 3) = Application.Transpose(Application.Transpose(d.Items)) '将字典的项目放入指定单元格
Set d = Nothing '释放字典对象
End Sub
Sub 多条件求和()
Dim arr, i%, s$, s2$
Dim d As New Dictionary '定义一个字典对象
arr = Range("a1").CurrentRegion.Value '将数据源赋给一个数组
ReDim brr(1 To UBound(arr), 1 To 3) '重新定义一个数组大小，用于存放结果
For i = 2 To UBound(arr) '对数组进行循环
s = arr(i, 1) & "|" & arr(i, 2) '将产品结合规格赋给一个变量
If d.Exists(s) Then '如果关键字已经存在
brr(d(s), 3) = brr(d(s), 3) + arr(i, 3) '将此关键字对应的数量进行累加
Else '如果关键字不存在
d(s) = d.Count + 1 '将此变量作关键字，关键字计数作项目，增加到字典中
brr(d(s), 1) = arr(i, 1) '将产品写入数组
brr(d(s), 2) = arr(i, 2) '将规格写入数组
brr(d(s), 3) = arr(i, 3) '将数量写入数组
End If
Next i
Range("a11:c1000").ClearContents '清空指定单元格区域内容
Range("a11").Resize(d.Count, 3) = brr '将结果写入指定单元格
Set d = Nothing '释放字典对象
End Sub
'=====附加题
Function NoRepeat(Rng As Range, Optional CompM As Byte = 0)
Dim arr, s
Dim d As New Dictionary '定义一个字典对象i
If CompM <> 1 Or CompM <> 0 Then NoRepeat = "": Exit Function '如果第二参数不为0或1，则结果为空，退出过程
If Rng.Count = 1 Then NoRepeat = Rng.Value: Exit Function '如果单元格区域为单个单元格，则结果为该单元格的值，退出过程
d.CompareMode = CompM '字典对象的字符串比较模式为第二参数
arr = Rng.Value '将单元格区域的值赋给一个数组
For Each s In arr '遍历数组
If Not d.Exists(s) Then d.Add s, "" '判断每一数组元素是否已在字典对象中，如果没有，则增加到字典中
Next
NoRepeat = Application.Transpose(d.Keys) '将字典的关键字返回给过程结果
Set d = Nothing '释放字典对象
End Function

复制代码

来交作业：

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

[习题] 【VBA字典数组201301班】C组- 第三讲作业上交处

相关帖子

评分

评分

评分

评分

评分

评分

评分

评分

评分