|
本帖最后由 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
复制代码 |
评分
-
查看全部评分
|