设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 培训班 › Excel VBA字典班 › 【VBA字典数组201301班】B组- 第三讲作业上交处
12下一页
返回列表 发新帖
查看: 6999|回复: 11

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

[复制链接]
发表于 2013-11-16 16:01 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 从从容容 于 2013-11-21 12:32 编辑

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

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

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

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

上交

相关帖子
回复

使用道具 举报

ls
发表于 2013-11-16 20:14 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
Option Explicit
Sub 求不重复值1()
    Dim d As Object, arr, i%, a
    Set d = CreateObject("scripting.dictionary")
    d.comparemode = 0
    arr = Sheet2.Range("a1:a12")
    For i = LBound(arr) To UBound(arr)
        d(arr(i, 1)) = ""
    Next
    a = d.keys
    [c2].Resize(d.Count) = WorksheetFunction.Transpose(a)
End Sub
Sub 求不重复值2()
    Dim d As Object, arr, i%, a
    Set d = CreateObject("scripting.dictionary")
    d.comparemode = 1
    arr = Sheet2.Range("a1:a12")
    For i = LBound(arr) To UBound(arr)
        d(arr(i, 1)) = ""
    Next
    a = d.keys
    [d2].Resize(d.Count) = WorksheetFunction.Transpose(a)
End Sub
Sub 双向求值()
    Dim d As Object, arr, i%, a
    Set d = CreateObject("scripting.dictionary")
    d.comparemode = 0
    arr = Sheet9.Range("a1:b6")
    For i = LBound(arr) To UBound(arr)
        d(arr(i, 1)) = arr(i, 2)
        d(arr(i, 2)) = arr(i, 1)
    Next
    [e3] = d([d3].Value)
    MsgBox "d3对应的值为" & [e3].Value
End Sub
Sub 多条件查找()
    Dim d As Object, arr, i%, a, b, c
    Set d = CreateObject("scripting.dictionary")
    d.comparemode = 0
    arr = Sheet8.Range("a2:d5")
    For i = LBound(arr) To UBound(arr)
        If d.exists(arr(i, 1)) = 0 Then
            d(arr(i, 1) & "|" & arr(i, 2)) = arr(i, 3) & "|" & arr(i, 4)
        Else
            d(arr(i, 1) & "|" & arr(i, 2)) = arr(i, 3) & "|" & arr(i, 4) + d(arr(i, 1) & "|" & arr(i, 2))
        End If
    Next
    b = d.keys
    c = d.items
    ReDim a(1 To d.Count, 1 To UBound(arr))
    For i = 0 To d.Count - 1
        a(i + 1, 1) = WorksheetFunction.Transpose(Split(b(i), "|")(0))
        a(i + 1, 2) = WorksheetFunction.Transpose(Split(b(i), "|")(1))
        a(i + 1, 3) = WorksheetFunction.Transpose(Split(c(i), "|")(0))
        a(i + 1, 4) = WorksheetFunction.Transpose(Split(c(i), "|")(1))
    Next
    [a12].Resize(d.Count, 4) = a
End Sub
Sub 单条件求和()
    Dim d As Object, arr, i%, a
    Set d = CreateObject("scripting.dictionary")
    d.comparemode = 0
    arr = Sheet10.Range("b2:c5")
    For i = LBound(arr) To UBound(arr)
        If d.exists(arr(i, 1)) = 0 Then
            d(arr(i, 1)) = arr(i, 2)
        Else
            d(arr(i, 1)) = arr(i, 2) + d(arr(i, 1))
        End If
    Next
    [e2].Resize(d.Count, 2) = WorksheetFunction.Transpose(Array(d.keys, d.items))
End Sub
Sub 多列求和()
    Dim d As Object, arr, i%, a(1 To 10000, 1 To 4), K%
    Set d = CreateObject("scripting.dictionary")
    d.comparemode = 0
    arr = Sheet12.Range("a2:d6")
    For i = LBound(arr) To UBound(arr)
        If d.exists(arr(i, 1)) = 0 Then
            K = K + 1
            d(arr(i, 1)) = K
            a(K, 1) = arr(i, 1)
            a(K, 2) = arr(i, 2)
            a(K, 4) = arr(i, 4)
        Else
            a(d(arr(i, 1)), 2) = arr(i, 2) + a(d(arr(i, 1)), 2)
            a(d(arr(i, 1)), 4) = arr(i, 4) + a(d(arr(i, 1)), 4)
        End If
        a(d(arr(i, 1)), 3) = a(d(arr(i, 1)), 4) / a(d(arr(i, 1)), 2)
    Next
    [a13].Resize(d.Count, 4) = a
End Sub
Sub 多条件求和()
    Dim d As Object, arr, i%, a, b, c
    Set d = CreateObject("scripting.dictionary")
    d.comparemode = 0
    arr = Sheet13.Range("a2:c6")
    For i = LBound(arr) To UBound(arr)
        If d.exists(arr(i, 1)) = 0 Then
            d(arr(i, 1) & "|" & arr(i, 2)) = arr(i, 3)
        Else
            d(arr(i, 1) & "|" & arr(i, 2)) = arr(i, 3) + d(arr(i, 1) & "|" & arr(i, 2))
        End If
    Next
    b = d.keys
    c = d.items
    ReDim a(1 To d.Count, 1 To UBound(arr, 2))
    For i = 0 To d.Count - 1
        a(i + 1, 1) = WorksheetFunction.Transpose(Split(b(i), "|")(0))
        a(i + 1, 2) = WorksheetFunction.Transpose(Split(b(i), "|")(1))
        a(i + 1, 3) = WorksheetFunction.Transpose(c(i))
    Next
    [a11].Resize(d.Count, 3) = a
End Sub

点评

从从容容
多条件查找和多条件求和 代码有点问题,还有没有注释. 其他都不错.  发表于 2013-11-21 10:24

评分

参与人数 1 +4 金币 +18 收起 理由
从从容容 + 4 + 18 赞一个!

查看全部评分

回复

使用道具 举报

wp8680
发表于 2013-11-16 20:45 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
B09:wp8680
  1. Option Explicit

  3. Sub 求不重复值1()
  4.     Dim d, arr, x%      '创建一些变量
  5.     Set d = CreateObject("Scripting.Dictionary")    '字典后期绑定
  6.     d.CompareMode = 0              '设置CompareMode为0，二进制比较
  7.     arr = Range("a1:a12")          '数据存入数组
  8.     For x = 1 To UBound(arr)       '建立循环
  9.         d(arr(x, 1)) = arr(x, 1)   '装入字典
  10.     Next x
  11.     Range("c2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.keys)
  12. End Sub

  14. Sub 求不重复值2()
  15.     Dim d, arr, x%      '创建一些变量
  16.     Set d = CreateObject("Scripting.Dictionary")
  17.     d.CompareMode = 1              '设置CompareMode为1，文本比较
  18.     arr = Range("a1:a12")          '数据存入数组
  19.     For x = 1 To UBound(arr)       '建立循环
  20.         d(arr(x, 1)) = arr(x, 1)   '装入字典
  21.     Next x
  22.     Range("d2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.keys)
  23. End Sub

  25. Sub 双向求值()
  26.     Dim d, arr, x%      '创建一些变量
  27.     Set d = CreateObject("Scripting.Dictionary")    '字典后期绑定
  28.     arr = Range("a2:b6")            '数据存入数组
  29.     For x = 1 To UBound(arr)        '建立循环
  30.         d(arr(x, 1)) = arr(x, 2)    '全部装入字典（因为地名不存在重名，简写也没有重名，取巧）
  31.         d(arr(x, 2)) = arr(x, 1)
  32.     Next x
  33.     MsgBox d.Item(Range("d3").Value)  '取出字典注释
  34. End Sub

  36. Sub 多条件查找()
  37.     Dim d, arr, brr, crr, x%   '创建一些变量
  38.     Set d = CreateObject("Scripting.Dictionary")    '字典后期绑定
  39.     arr = Range("a2:d5")          '数据存入数组
  40.     brr = Range("a12:b13")        '建立条件区的数组
  41.     crr = Range("c12:d13")        '建立结果区的数组
  42.     For x = 1 To UBound(arr)       '建立循环
  43.         d(arr(x, 1) & "|" & arr(x, 2)) = arr(x, 3) & "|" & arr(x, 4)    '装入字典
  44.     Next x
  45.     For x = 1 To 2                  '结果区逐行循环
  46.         crr(x, 1) = Split(d.Item(brr(x, 1) & "|" & brr(x, 2)), "|")(0)  '结果区逐行的第一列
  47.         crr(x, 2) = Split(d.Item(brr(x, 1) & "|" & brr(x, 2)), "|")(1)  '结果区逐行的第二列
  48.     Next x
  49.     Range("c12:d13") = crr     '把数组写入结果区
  50. End Sub

  52. Sub 单条件求和()
  53.     Dim d, arr, x%      '创建一些变量
  54.     Set d = CreateObject("Scripting.Dictionary")    '字典后期绑定
  55.     arr = Range("b2:c5")          '数据存入数组
  56.     For x = 1 To UBound(arr)       '建立循环
  57.         d(arr(x, 1)) = d(arr(x, 1)) + arr(x, 2)    '装入字典
  58.     Next x
  59.     Range("e2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.keys)     '把字典key写入结果区
  60.     Range("F2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.items)     '把字典item写入结果区
  61. End Sub

  63. Sub 多列求和()
  64.     Dim d, arr, brr(), x%, y%  '创建一些变量
  65.     Set d = CreateObject("Scripting.Dictionary")    '字典后期绑定
  66.     arr = Range("a2:d6")          '数据存入数组
  67.     For x = 1 To UBound(arr)    '建立循环
  68.         If Not d.Exists(arr(x, 1)) Then
  69.             y = y + 1
  70.             d(arr(x, 1)) = y    '装入字典，并以字典Key出现为顺序编号注释
  71.         End If
  72.         ReDim Preserve brr(1 To 3, 1 To y)   '建立动态数组存放数据
  73.         '用arr(x,1)在字典中的注释（即序号）去定义动态数组brr中列位置，然后累加或赋值，我估计我的此方法跟他们说的棋盘法略同规则。
  74.         brr(1, d.Item(arr(x, 1))) = brr(1, d.Item(arr(x, 1))) + arr(x, 2)
  75.         brr(2, d.Item(arr(x, 1))) = arr(x, 3)
  76.         brr(3, d.Item(arr(x, 1))) = brr(3, d.Item(arr(x, 1))) + arr(x, 4)
  77.     Next x
  78.     Range("a13").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.keys)    '把字典key写入结果区
  79.     Range("b13").Resize(d.Count, 3) = Application.WorksheetFunction.Transpose(brr)  '把数组brr写入结果区
  80. End Sub


  83. Sub 多条件求和()
  84.     Dim d, arr, brr, crr(), x%   '创建一些变量
  85.     Set d = CreateObject("Scripting.Dictionary")    '字典后期绑定
  86.     arr = Range("a2:c6")          '数据存入数组
  87.     For x = 1 To UBound(arr)       '建立循环
  88.         d(arr(x, 1) & "|" & arr(x, 2)) = d(arr(x, 1) & "|" & arr(x, 2)) + arr(x, 3)    '装入字典
  89.     Next x
  90.     brr = d.keys
  91.     ReDim crr(1 To d.Count, 1 To 2)
  92.     For x = 1 To d.Count
  93.         crr(x, 1) = Split(brr(x - 1), "|")(0)
  94.         crr(x, 2) = Split(brr(x - 1), "|")(1)
  95.     Next x
  96.     Range("a11").Resize(d.Count, 2) = crr  '把数组crr写入表格
  97.     Range("c11").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.items)    '把字典item写入表格
  98. End Sub
复制代码

点评

从从容容
答案正确,并能运用前面学习过的动态数组,很好的, 继续努力, 有点小建议,如果在多条件查找和多条件求和 如果能用 字典与数组 组合运用,代码会更简洁.字典做行标,数组做容器......  发表于 2013-11-21 10:38

评分

参与人数 1 +6 金币 +20 收起 理由
从从容容 + 6 + 20 很给力!

查看全部评分

回复

使用道具 举报

发表于 2013-11-16 22:01 | 显示全部楼层
B06幽月儿

Option Explicit
Sub 求不重复值1()
    Dim d As Object, arr, i As Integer
    Set d = CreateObject("scripting.dictionary")
    d.CompareMode = 2
    arr = Range("a1:a12")
    For i = 1 To UBound(arr)
        d(arr(i, 1)) = ""
    Next
    [c2].Resize(d.Count) = Application.Transpose(d.keys)
End Sub
Sub 求不重复值2()
    Dim d As Object, arr, i As Integer
    Set d = CreateObject("scripting.dictionary")
    d.CompareMode = 0
    arr = Range("a1:a12")
    For i = 1 To UBound(arr)
        d(arr(i, 1)) = ""
    Next
    [d2].Resize(d.Count) = Application.Transpose(d.keys)
End Sub
Sub 双向求值()
    Dim d As Object, arr, i As Integer
    Set d = CreateObject("scripting.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 d As Object, arr, i As Integer, k, l
    Set d = CreateObject("scripting.dictionary")
    arr = Range("a2:d5")
    For i = 1 To UBound(arr)
        d(arr(i, 1) & "-" & arr(i, 2)) = Array(arr(i, 3), arr(i, 4))
    Next i
    k = d.keys
    l = d.items
    For i = 0 To d.Count - 1
        If [a12].Value & "-" & [b12].Value = k(i) Then
            [c12].Resize(1, 2) = l(i)
        End If
        If [a13].Value & "-" & [b13].Value = k(i) Then
            [c13].Resize(1, 2) = l(i)
        End If
    Next i
End Sub
Sub 单条件求和()
    Dim d As Object, arr, i As Integer
    Set d = CreateObject("scripting.dictionary")
    arr = Range("b2:c5")
    For i = 1 To UBound(arr)
        d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
    Next i
    [e2].Resize(d.Count) = Application.Transpose(d.keys)
    [f2].Resize(d.Count) = Application.Transpose(d.items)
End Sub
Sub 多列求和()
    Dim arr1(), d As Object, i As Integer, n As Integer, m As Integer, arr
    Set d = CreateObject("scripting.dictionary")
    arr = Range("a2:d6")
    For i = 1 To UBound(arr)
        If Not d.exists(arr(i, 1)) Then
            n = n + 1
            d(arr(i, 1)) = n
            ReDim Preserve arr1(1 To 4, 1 To n)
            arr1(1, n) = arr(i, 1)
            arr1(2, n) = arr(i, 2)
            arr1(3, n) = arr(i, 3)
            arr1(4, n) = arr(i, 4)
        Else
            m = d(arr(i, 1))
            arr1(2, m) = arr1(2, m) + arr(i, 2)
            arr1(3, m) = arr1(3, m) + arr(i, 3)
            arr1(4, m) = arr1(4, m) + arr(i, 4)
        End If
    Next
    [a13].Resize(n, 4) = Application.Transpose(arr1)
End Sub

Sub 多条件求和()
    Dim d As Object, i As Integer, arr, arr1, l, brr
    Set d = CreateObject("scripting.dictionary")
    arr = Range("a2:c6")
    For i = 1 To UBound(arr)
        d(arr(i, 1) & "-" & arr(i, 2)) = d(arr(i, 1) & "-" & arr(i, 2)) + arr(i, 3)
    Next i
    arr1 = d.keys
    l = d.items
    For i = 0 To 3
        brr = VBA.Split(arr1(i), "-")
        Cells(i + 11, 1).Resize(1, 2) = brr
    Next i
    [c11].Resize(d.Count) = Application.Transpose(d.items)
End Sub

点评

从从容容
求不重复值 1,和2 错位了,多列求和 "单价" 没有处理好,总体很不错, 小建议,多条件查找和多条件求和 还可以再优化.  发表于 2013-11-21 10:48

评分

参与人数 1 +4 金币 +19 收起 理由
从从容容 + 4 + 19 赞一个!

查看全部评分

回复

使用道具 举报

zjyxp
发表于 2013-11-17 18:04 | 显示全部楼层
【VBA字典数组201301班】B组 第三讲作业 b05:zjyxp上交作业，请学委老师批改指点，谢谢！
本次作业字典都是前期绑定
作业一
1、 求不重复值1
  1. Sub 求不重复值1()
  2.     Dim d As New Dictionary
  3.     Dim arr, i As Integer
  4.     Range("c2:c12").ClearContents '清空C2：C12单元格数据
  5.     arr = Range("a1:a12") '将单元格A1:A12读入数组
  6.     d.CompareMode = 0 '设定字典为不区分大小写模式
  7.     For i = 1 To UBound(arr, 1)
  8.         If d.Exists(arr(i, 1)) = False Then d(arr(i, 1)) = "" '判断数组元素在字典里是否存在，不存在创建字典
  9.     Next i
  10.         [c2].Resize(d.Count, 1) = Application.Transpose(d.Keys) '将字典KEYS读入指定位置
  11. End Sub
复制代码
2、求不重复值2()
  1. Sub 求不重复值2()
  2.     Dim d As New Dictionary
  3.     Dim arr, i As Integer
  4.     Range("d2:d12").ClearContents '清空D2：D12单元格数据
  5.     arr = Range("a1:a12") '将单元格A1:A12读入数组
  6.     d.CompareMode = 1 '设定字典为区分大小写模式
  7.     For i = 1 To UBound(arr, 1)
  8.         If d.Exists(arr(i, 1)) = False Then d(arr(i, 1)) = "" '判断数组元素在字典里是否存在，不存在创建字典
  9.     Next i
  10.         [d2].Resize(d.Count, 1) = Application.Transpose(d.Keys) '将字典KEYS读入指定位置
  11. End Sub
复制代码
作业二：双向查找（工作表事件）在sheets("双向查找")中
  1. Private Sub Worksheet_Change(ByVal Target As Range) '设定工作表事件
  2.     Dim arr, d As New Dictionary
  3.     Dim i As Integer
  4.     If Target.Address = "$D$3" Then '设定工作表变化单元格位置
  5.     arr = Range("a2:b6")
  6.     For i = 1 To UBound(arr)
  7.         d(arr(i, 1)) = arr(i, 2) '将数组第一列读入字典
  8.     Next i
  9.     For i = 1 To UBound(arr)
  10.         d(arr(i, 2)) = arr(i, 1) '将数组第二列读入字典
  11.     Next i
  12.         MsgBox d(Target.Value) '读出单元格D3的对应项
  13.     End If
  14. End Sub
复制代码
作业三：单条件求和
  1. Sub 单条件求和()
  2.     Dim arr, d As New Dictionary
  3.     Dim i As Integer
  4.     arr = Range("b2:c5") '将数据读入数组
  5.     For i = 1 To UBound(arr)
  6.         d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2) '通过循环将字典数组累加
  7.     Next i
  8.         [e2].Resize(d.Count, 1) = Application.Transpose(d.Keys) '将字典的KEYS值读入指定位置
  9.         [f2].Resize(d.Count, 1) = Application.Transpose(d.Items) '将字典的ITEMSS值读入指定位置
  10. End Sub
复制代码
作业四：多条件查找
  1. Sub 多条件查找()
  2.     Dim arr, brr, crr
  3.     Dim d1 As New Dictionary, d2 As New Dictionary
  4.     Dim i As Integer
  5.     '将相关数据放入arr和brr
  6.     arr = Range("a2:d5")
  7.     brr = Range("a12:b13")
  8.     ReDim crr(1 To UBound(brr), 1 To 2) '重新定义crr
  9.     For i = 1 To UBound(arr)
  10.         '将数组放进字典
  11.         d1(arr(i, 1) & "-" & arr(i, 2)) = d1(arr(i, 1) & "-" & arr(i, 2)) + arr(i, 3)
  12.         d2(arr(i, 1) & "-" & arr(i, 2)) = arr(i, 4)
  13.     Next i
  14.     For i = 1 To UBound(brr)
  15.         '将数组从字典中读进crr
  16.         crr(i, 1) = d1.Item(brr(i, 1) & "-" & brr(i, 2))
  17.         crr(i, 2) = d2.Item(brr(i, 1) & "-" & brr(i, 2))
  18.     Next i
  19.         [c12].Resize(UBound(crr), 2) = crr '将crr读进指定区域
  20. End Sub
复制代码
作业五：多列求和

  2. Sub 多列求和()
  3.     Dim arr
  4.     Dim k As Integer
  5.     Dim d1 As New Dictionary, d2 As New Dictionary, d3 As New Dictionary
  6.     arr = Range("a2:d6") '将数据读入数组
  7.     For k = 1 To UBound(arr)
  8.         '通过循环将数据装入各个字典
  9.         d1(arr(k, 1)) = d1(arr(k, 1)) + arr(k, 2)
  10.         d2(arr(k, 1)) = arr(k, 3)
  11.         d3(arr(k, 1)) = d3(arr(k, 1)) + arr(k, 4)
  12.     Next k
  13.         '将相关数据读入指定区域
  14.         Range("a13").Resize(d1.Count, 1) = Application.Transpose(d1.Keys)
  15.         Range("b13").Resize(d1.Count, 1) = Application.Transpose(d1.Items)
  16.         Range("c13").Resize(d1.Count, 1) = Application.Transpose(d2.Items)
  17.         Range("d13").Resize(d1.Count, 1) = Application.Transpose(d3.Items)
  18. End Sub
复制代码
作业六：多条件求和
  1. Sub 多条件求和()
  2.     Dim arr, brr
  3.     Dim d As New Dictionary
  4.     Dim i As Integer
  5.     arr = Range("a2:c6") '将区域数据读入数组
  6.     For i = 1 To UBound(arr)
  7.         '将数组元素1连接元素2组成字典KEY，再进行累加
  8.         d(arr(i, 1) & "-" & arr(i, 2)) = d(arr(i, 1) & "-" & arr(i, 2)) + arr(i, 3)
  9.     Next i
  10.     ReDim brr(1 To d.Count, 1 To 3) '重置数组brr
  11.     For i = 1 To d.Count
  12.         brr(i, 1) = Split(d.Keys(i - 1), "-")(0) '将分割出来的数据入进brr
  13.         brr(i, 2) = Split(d.Keys(i - 1), "-")(1)
  14.         brr(i, 3) = d.Items(i - 1)
  15.     Next i
  16.         [a11].Resize(UBound(brr), UBound(brr, 2)) = brr '将brr读入指定位置
  17. End Sub
复制代码

点评

从从容容
代码不要,每题分开,不好测试.  发表于 2013-11-21 11:45
从从容容
双向查找 代码不要写在工作表事件中,没有反应, 代码只要一个循环就可以了, 多条件查找,也有一点问题. 有的定义多个字典,不够简洁.  发表于 2013-11-21 11:43

评分

参与人数 1 +3 金币 +17 收起 理由
从从容容 + 3 + 17 赞一个!

查看全部评分

回复

使用道具 举报

发表于 2013-11-17 20:32 | 显示全部楼层
本帖最后由 雨后彩霞 于 2013-11-18 11:53 编辑

第三题作业。
Sub 求不重复值1()
    Dim i As Long
    Dim d As New Dictionary
    For i = 1 To 12
        d.CompareMode = 1
        d(Cells(i, 1).Value) = d(Cells(i, 1).Value)
    Next i
    Range("c2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Keys)
End Sub
Sub 求不重复值2()
    Dim i As Long
    Dim d As New Dictionary
    For i = 1 To 12
        d(Cells(i, 1).Value) = d(Cells(i, 1).Value)
    Next i
    Range("d2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Keys)
End Sub
Sub 双向求值()
    Dim d As New Dictionary
    Dim arr()
    Dim 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)
            d.Add arr(x, 2), arr(x, 1)    '添加字典
        Next x
    ElseIf Not (IsNumeric(Left(Mys, 1))) Then    '判断是否汉字
        For x = 1 To UBound(arr)
            d.Add arr(x, 1), arr(x, 2)    '添加字典
        Next x
    End If
    arr = Range("d3:e3")
    arr(1, 2) = d.Item(arr(1, 1))    '查找
MsgBox arr(1, 2)
     Set d = Nothing
    Erase arr
End Sub


Sub 多条件查找()
    Dim d As New Dictionary
    Dim arr(), brr()
    Dim x, y, m, k
    arr = Range("A2:d5")
    brr = Range("A12:D13")
    For x = 1 To UBound(arr)
        m = arr(x, 1) & vbTab & arr(x, 2)
        d.Add m, arr(x, 3) & "," & arr(x, 4)
    Next x
    For y = 1 To UBound(brr)
        m = brr(y, 1) & vbTab & brr(y, 2)
        If d.Exists(m) Then
            brr(y, 3) = Split(d(m), ",")(0)
            brr(y, 4) = Split(d(m), ",")(1)
        End If
    Next
    [A12].Resize(2, 4) = brr
End Sub
Sub 单条件求和()
    Dim i
    Dim d As New Dictionary
    For i = 2 To 5
        d(Cells(i, 2).Value) = d(Cells(i, 2).Value) + Cells(i, 3)
    Next i
    Range("e2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Keys)
    Range("f2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Items)
End Sub
Sub 多列求和()
    Dim i
    Dim d As New Dictionary
    Dim arr, arr1
    arr = Range("a2:d6")
    ReDim arr1(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    For i = 1 To UBound(arr)
        If d.Exists(arr(i, 1)) = False Then
            d(arr(i, 1)) = d.Count + 1
            arr1(d(arr(i, 1)), 1) = arr(i, 1)
        End If
        arr1(d(arr(i, 1)), 2) = arr1(d(arr(i, 1)), 2) + arr(i, 2)
        arr1(d(arr(i, 1)), 3) = arr1(d(arr(i, 1)), 3) + arr(i, 3)
        arr1(d(arr(i, 1)), 4) = arr1(d(arr(i, 1)), 4) + arr(i, 4)
    Next i
    Range("a13").Resize(d.Count, 4) = arr1
End Sub
Sub 多条件求和()
    Dim x, y
    Dim arr, arr1, arr2(1 To 1000, 1 To 2), arr3
    Dim d As New Dictionary
    arr = Range("a2:c6")
    For x = 1 To UBound(arr)
        d(arr(x, 1) & "-" & arr(x, 2)) = d(arr(x, 1) & "-" & arr(x, 2)) + arr(x, 3)    '把需要汇总的列进行连接
    Next x

    arr1 = d.Keys
    For y = 0 To UBound(arr1)
        arr3 = Split(arr1(y), "-")    '把连接的产品和型号列进行拆分
        arr2(y + 1, 1) = arr3(0)  '拆分后的放进arr2数组中
        arr2(y + 1, 2) = arr3(1)
    Next y
    Range("a11").Resize(d.Count, 2) = arr2
    Range("c11").Resize(d.Count) = Application.Transpose(d.Items)
End Sub

点评

从从容容
第一题 错位, 双向查找,不够简洁.还可以优化. 多列求和 "单价 "不对, 总体很不错,  发表于 2013-11-21 11:53

评分

参与人数 1 +5 金币 +18 收起 理由
从从容容 + 5 + 18 赞一个!

查看全部评分

回复

使用道具 举报

zmnyu
发表于 2013-11-17 21:13 | 显示全部楼层
B03-zmnyu交第三课时作业：
  1. Sub 求不重复值1()
  2.     Dim d As New Dictionary
  3.     Dim arr()
  4.     Dim i As Integer
  5.     Dim n As Integer
  6.     n = Range("A" & Rows.Count).End(xlUp).Row
  7.     '取A列当前数据的最大行号，赋值给n
  8.     arr() = Range("A1:A" & n).Value
  9.     '把A1:An的值装入数组arr
  10.     For i = 1 To UBound(arr)  '循环arr数组内容
  11.         d(arr(i, 1)) = ""
  12.         '指定字典d内以arr(i,1)为key的item值为空，如果此key不存在，则新建
  13.     Next
  14.     Range("C2").Resize(d.Count, 1) = Application.Transpose(d.Keys)
  15.     '输出字典d的keys到以C2为开始的单元格区域
  16. End Sub
复制代码
  1. Sub 求不重复值2()
  2.     Dim d As New Dictionary
  3.     Dim arr()
  4.     Dim i As Integer
  5.     Dim n As Integer
  6.     n = Range("A" & Rows.Count).End(xlUp).Row
  7.     '取A列当前数据的最大行号，赋值给n
  8.     arr() = Range("A1:A" & n).Value
  9.     '把A1:An的值装入数组arr
  10.     d.CompareMode = 1   '指定字典d的文字对比模式为不区分大小写
  11.     For i = 1 To UBound(arr)    '循环arr数组内容
  12.         d(arr(i, 1)) = ""
  13.         '指定字典d内以arr(i,1)为key的item值为空，如果此key不存在，则新建
  14.     Next
  15.     Range("D2").Resize(d.Count, 1) = Application.Transpose(d.Keys)
  16.     '输出字典d的keys到以D2为开始的单元格区域
  17. End Sub
复制代码
  1. Sub 双向求值()
  2.     Dim d As New Dictionary
  3.     Dim i As Integer
  4.     Dim arr()
  5.     arr() = Range("A2:B6").Value    '把A2:B6的值装入数组arr
  6.     For i = 1 To UBound(arr)       '循环
  7.         d(arr(i, 1)) = arr(i, 2)   '建立字典d的条目，key为arr(i,1),item为arr(i,2)
  8.         d(arr(i, 2)) = arr(i, 1)     '建立字典d的条目，key为arr(i,2),item为arr(i,1)
  9.     Next
  10.     MsgBox "查询条目：" & Range("D3").Value & Chr(10) & "查询结果：" & d(Range("D3").Value), , "B03-zmnyu提示"
  11.     '以消息框显示查询的内容
  12. End Sub
复制代码
  1. Sub 多条件查找()
  2.     Dim i As Integer
  3.     Dim d1 As New Dictionary, d2 As New Dictionary
  4.     Dim arr()
  5.     arr() = Range("A2:D5").Value
  6.     '把数据源区域装入数组arr
  7.     For i = 1 To UBound(arr)
  8.         d1(arr(i, 1) & "-" & arr(i, 2)) = arr(i, 3)
  9.         d2(arr(i, 1) & "-" & arr(i, 2)) = arr(i, 4)
  10.         '通过循环建议d1和d2两个字典的条目
  11.     Next
  12.     arr() = Range("A12:D13").Value
  13.     '把结果区域需要查询的条件装入数组arr
  14.     For i = 1 To UBound(arr)
  15.         arr(i, 3) = d1(arr(i, 1) & "-" & arr(i, 2))
  16.         arr(i, 4) = d2(arr(i, 1) & "-" & arr(i, 2))
  17.         '把查询结果装入数组arr
  18.     Next
  19.     Range("A12:D13") = arr
  20.     '查询结果写入结果区域
  21. End Sub
复制代码
  1. Sub 单条件求和()
  2.     Dim i As Integer
  3.     Dim d As New Dictionary
  4.     Dim arr()
  5.     arr() = Range("B2:C5").Value
  6.     '把区域B2:C5的值装入数组
  7.     For i = 1 To UBound(arr)  '循环
  8.         d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
  9.         '字典d当前条目的item值等于原来item值加上当前行的数量之和
  10.     Next
  11.     Range("E2").Resize(d.Count, 1) = Application.Transpose(d.Keys)
  12.     '把字典的keys值（即产品名称）输出
  13.     Range("F2").Resize(d.Count, 1) = Application.Transpose(d.Items)
  14.     '把字典的items值（对应产品的数量之和）输出
  15. End Sub
复制代码
  1. Sub 多列求和()
  2.     Dim d1 As New Dictionary, d2 As New Dictionary, d3 As New Dictionary
  3.     Dim i As Integer
  4.     Dim arr()
  5.     arr() = Range("A2:D6").Value
  6.     '把数据源区域装入数组
  7.     For i = 1 To UBound(arr)
  8.         d1(arr(i, 1)) = d1(arr(i, 1)) + arr(i, 2)
  9.         d2(arr(i, 1)) = arr(i, 3)
  10.         d3(arr(i, 1)) = d3(arr(i, 1)) + arr(i, 4)
  11.         '通过循环分别建立字典d1,d2,d3分别存放数量的和，单价，金额的和
  12.     Next
  13.         '以下四句为结果写入
  14.     Range("A13").Resize(d1.Count, 1) = Application.Transpose(d1.Keys)
  15.     Range("B13").Resize(d1.Count, 1) = Application.Transpose(d1.Items)
  16.     Range("C13").Resize(d1.Count, 1) = Application.Transpose(d2.Items)
  17.     Range("D13").Resize(d1.Count, 1) = Application.Transpose(d3.Items)
  18. End Sub
复制代码
  1. Sub 多条件求和()
  2.     Dim i As Integer
  3.     Dim d As New Dictionary
  4.     Dim arr()
  5.     arr() = Range("A2:C6").Value
  6.     '把数据源区域装入数组arr
  7.     For i = 1 To UBound(arr)  '循环
  8.         d(arr(i, 1) & "-" & arr(i, 2)) = d(arr(i, 1) & "-" & arr(i, 2)) + arr(i, 3)
  9.         '以产品和规格中间以“-”连接为条目创建字典，item值为当前item值加上当前行的数量
  10.     Next
  11.     arr = d.Keys   '把字典d的keys装入数组arr
  12.     For i = 1 To d.Count   '循环
  13.         arr(i - 1) = Split(arr(i - 1), "-")
  14.         '把经过连接的产品和规格重新拆分开
  15.     Next
  16.     Range("a11").Resize(UBound(arr) + 1, 2) = Application.Transpose(Application.Transpose(arr))
  17.     '把拆分后的产品名称和规格写入结果区域
  18.     Range("c11").Resize(d.Count, 1) = Application.Transpose(d.Items)
  19.     '把求和后的数量写入结果区域
  20. End Sub
复制代码
B03-zmnyu【VBA字典数组201301班】第三讲 作业.rar (52.5 KB, 下载次数: 32)

评分

参与人数 1 +6 金币 +20 收起 理由
从从容容 + 6 + 20 赞一个!

查看全部评分

回复

使用道具 举报

发表于 2013-11-18 08:31 | 显示全部楼层
B08:缔造者
  1. Option Explicit

  3. Sub 求不重复值1()
  4.     Dim d As Object '变量d声明为对象变量
  5.     Dim arr '变量arr声明为变体型变量
  6.     Dim i As Integer '变量i声明为整型值变量
  7.     Set d = CreateObject("scripting.dictionary") '创建字典对象，并把字典对象赋值给变量d
  8.     d.comparemode = 0 '设置字典的比较模式是二进制，即区分大小写
  9.     With Sheets("求不重复值") '执行with语句块
  10.         arr = .Range("a1").CurrentRegion '将a1单元格所在的区域赋值给变量arr，此时arr变为数组
  11.         For i = 1 To UBound(arr) '遍历数组arr
  12.             d(arr(i, 1)) = "" '将数组的每个值作为关键字添加到字典中，其对应的项为空
  13.         Next i '继续循环下一个变量i
  14.         .[c2].Resize(d.Count) = Application.Transpose(d.keys) '将字典的关键字通过转置赋值给结果区域
  15.     End With '结束with语句块
  16.     Set d = Nothing '释放字典内存
  17. End Sub

  19. Sub 求不重复值2()
  20.     Dim d As Object '变量d声明为对象变量
  21.     Dim arr '变量arr声明为变体型变量
  22.     Dim i As Integer '变量i声明为整型值变量
  23.     Set d = CreateObject("scripting.dictionary") '创建字典对象，并把字典对象赋值给变量d
  24.     d.comparemode = 1 '设置字典的比较模式是文本，即不区分大小写
  25.     With Sheets("求不重复值") '执行with语句块
  26.         arr = .Range("a1").CurrentRegion '将a1单元格所在的区域赋值给变量arr，此时arr变为数组
  27.         For i = 1 To UBound(arr) '遍历数组arr
  28.             d(arr(i, 1)) = "" '将数组的每个值作为关键字添加到字典中，其对应的项为空
  29.         Next i '继续循环下一个变量i
  30.         .[d2].Resize(d.Count) = Application.Transpose(d.keys) '将字典的关键字通过转置赋值给结果区域
  31.     End With '结束with语句块
  32.     Set d = Nothing '释放字典内存
  33. End Sub

  35. Sub 双向求值()
  36.     Dim d As Object '变量d声明为对象变量
  37.     Dim arr '变量arr声明为变体型变量
  38.     Dim i As Integer '变量i声明为整型值变量
  39.     Set d = CreateObject("scripting.dictionary") '创建字典对象，并把字典对象赋值给变量d
  40.     With Sheets("双向查找") '执行with语句块
  41.         arr = .Range("a1").CurrentRegion '将a1单元格所在的区域赋值给变量arr，此时arr变为数组
  42.         For i = 2 To UBound(arr) '遍历数组arr
  43.             d(arr(i, 1)) = arr(i, 2) '将数组第一列的每个值作为关键字添加到字典中，其对应的项为数组第一列对应的第二列的值
  44.             d(arr(i, 2)) = arr(i, 1) '将数组第二列的每个值作为关键字添加到字典中，其对应的项为数组第二列对应的第一列的值
  45.         Next i '继续循环下一个变量i
  46.         MsgBox .[d3].Value & "的对应值是：" & d(.[d3].Value) '通过消息框提示条件关键字D3单元格里的值所对应的项
  47.     End With '结束with语句块
  48.     Set d = Nothing '释放字典内存
  49. End Sub

  51. Sub 多条件查找()
  52.     Dim d As Object '变量d声明为对象变量
  53.     Dim arr, brr '变量arr和brr声明为变体型变量
  54.     Dim i As Integer, s '变量i声明为整型值变量，变量s声明为变体型变量
  55.     Set d = CreateObject("scripting.dictionary") '创建字典对象，并把字典对象赋值给变量d
  56.     With Sheets("多条件查找") '执行with语句块
  57.         arr = .Range("a1").CurrentRegion '将a1单元格所在的区域赋值给变量arr，此时arr变为数组
  58.         For i = 2 To UBound(arr) '遍历数组arr
  59.             d(arr(i, 1) & arr(i, 2)) = arr(i, 3) & "," & arr(i, 4) '将数组第一列连接第二列的每个值作为关键字添加到字典中，其对应的项为数组的第三列与第四列并用逗号分隔
  60.         Next i '继续循环下一个变量i
  61.         brr = .Range("a12:b13") '将条件区域赋值给变量brr，此时变量brr变为二维数组
  62.         For i = 1 To UBound(brr) '遍历数组brr
  63.             If d.exists(brr(i, 1) & brr(i, 2)) Then '如果字典中已存在关键字
  64.                 s = Split(d(brr(i, 1) & brr(i, 2)), ",") '将字典中的项，按逗号拆分并赋值给变量s，此时变量s变为一维数组
  65.                 .Cells(i + 11, 3).Resize(1, 2).Value = Application.Transpose(Application.Transpose(s)) '通过两次转置将数组s的值由文本转为数值并赋值给结果区域
  66.             Else
  67.                 MsgBox "产品或者规格不存在，请修改！" '通过消息框提示不存在的产品或者规格
  68.             End If
  69.         Next i '继续循环下一个变量i
  70.     End With '结束with语句块
  71.     Set d = Nothing '释放字典内存
  72. End Sub

  74. Sub 单条件求和()
  75.     Dim d As Object '变量d声明为对象变量
  76.     Dim arr '变量arr声明为变体型变量
  77.     Dim i As Integer '变量i声明为整型值变量
  78.     Set d = CreateObject("scripting.dictionary") '创建字典对象，并把字典对象赋值给变量d
  79.     With Sheets("单条件求和") '执行with语句块
  80.         arr = .Range("a1").CurrentRegion '将a1单元格所在的区域赋值给变量arr，此时arr变为数组
  81.         For i = 2 To UBound(arr) '遍历数组arr
  82.             d(arr(i, 2)) = d(arr(i, 2)) + arr(i, 3) '将数组第二列的每个值作为关键字添加到字典中，其对应的项为累加
  83.         Next i '继续循环下一个变量i
  84.         .[e2].Resize(d.Count) = Application.Transpose(d.keys) '将字典的关键字通过转置赋值给结果区域
  85.         .[f2].Resize(d.Count) = Application.Transpose(d.items) '将字典的项通过转置赋值给结果区域
  86.     End With '结束with语句块
  87.     Set d = Nothing '释放字典内存
  88. End Sub

  90. Sub 多列求和()
  91.     Dim d As Object, d1 As Object, d2 As Object '变量d和d1及d2声明为对象变量
  92.     Dim arr '变量arr声明为变体型变量
  93.     Dim i As Integer '变量i声明为整型值变量
  94.     Set d = CreateObject("scripting.dictionary") '创建字典对象，并把字典对象赋值给变量d
  95.     Set d1 = CreateObject("scripting.dictionary") '创建字典对象，并把字典对象赋值给变量d1
  96.     Set d2 = CreateObject("scripting.dictionary") '创建字典对象，并把字典对象赋值给变量d2
  97.     With Sheets("多列求和") '执行with语句块
  98.         arr = .Range("a1").CurrentRegion '将a1单元格所在的区域赋值给变量arr，此时arr变为数组
  99.         For i = 2 To UBound(arr) '遍历数组arr
  100.             d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2) '将数组第一列的每个值作为关键字添加到字典中，其对应的项为累加
  101.             d1(arr(i, 1)) = arr(i, 3) '将数组第一列的每个值作为关键字添加到字典中，其对应的项为数组第三列的值
  102.             d2(arr(i, 1)) = d2(arr(i, 1)) + arr(i, 4) '将数组第一列的每个值作为关键字添加到字典中，其对应的项为连接
  103.         Next i '继续循环下一个变量i
  104.         .Cells(13, 1).Resize(d.Count) = Application.Transpose(d.keys) '将字典的关键字通过转置赋值给结果区域
  105.         .[b13].Resize(d.Count) = Application.Transpose(d.items) '将字典的项通过转置赋值给结果区域
  106.         .[c13].Resize(d1.Count) = Application.Transpose(d1.items) '将字典的项通过转置赋值给结果区域
  107.         .[d13].Resize(d2.Count) = Application.Transpose(d2.items) '将字典的项通过转置赋值给结果区域
  108.     End With '结束with语句块
  109.     Set d = Nothing '释放字典内存
  110.     Set d1 = Nothing '释放字典内存
  111.     Set d2 = Nothing '释放字典内存
  112. End Sub


  115. Sub 多条件求和()
  116.     Dim d As Object '变量d声明为对象变量
  117.     Dim arr, brr '变量arr和brr声明为变体型变量
  118.     Dim i As Integer, j As Integer, s '变量i和j声明为整型值变量，变量s声明为变体型变量
  119.     Set d = CreateObject("scripting.dictionary") '创建字典对象，并把字典对象赋值给变量d
  120.     With Sheets("多条件求和") '执行with语句块
  121.         arr = .Range("a1").CurrentRegion '将a1单元格所在的区域赋值给变量arr，此时arr变为数组
  122.         For i = 2 To UBound(arr) '遍历数组arr
  123.             d(arr(i, 1) & " " & arr(i, 2)) = d(arr(i, 1) & " " & arr(i, 2)) + arr(i, 3) '将数组第一列与第二列用空格连接起来的每个值作为关键字添加到字典中，其对应的项为累加
  124.         Next i '继续循环下一个变量i
  125.         s = d.keys '将字典关键字赋值给变量s，此时变量s变为一维数组
  126.         brr = .Range("a11:b" & UBound(s) + 11) '将结果区域赋值给变量brr，此时变量brr变为二维数组
  127.         For j = 1 To 2 '变量j开始循环
  128.             For i = 1 To UBound(s) + 1 '遍历数组s
  129.                 brr(i, j) = Split(s(i - 1), " ")(j - 1) '按空格拆分数组s，分别提取其第1、2项并赋值给二维数组brr对应的行和列
  130.             Next i '继续循环下一个变量i
  131.         Next j '继续循环下一个变量j
  132.         .[a11].Resize(d.Count, 2) = brr '将数组brr赋值给结果区域
  133.         .[c11].Resize(d.Count) = Application.Transpose(d.items) '将字典的项通过转置赋值给结果区域
  134.     End With '结束with语句块
  135.     Set d = Nothing '释放字典内存
  136. End Sub
复制代码

点评

从从容容
代码注释很清楚,考虑很两到,有一定的功底,很好 小建议,代码还可以优化,如 减少循环次数.  发表于 2013-11-21 12:06

评分

参与人数 1 +6 金币 +20 收起 理由
从从容容 + 6 + 20 很给力!

查看全部评分

回复

使用道具 举报

发表于 2013-11-19 14:36 | 显示全部楼层
b10 临时户口
  1. Option Explicit
  2. Public 字典 As New Dictionary    '创建一个公共的字典
  3. Public arr, i

  5. Sub 求不重复值1()  '区分大小写
  6.     Sheet2.Range("c2:c12").ClearContents
  7.     arr = Sheet2.Range("a1:a12").Value
  8.     For i = 1 To UBound(arr)
  9.         字典(arr(i, 1)) = ""           '字典创建关键字
  10.     Next
  11.     Sheet2.Range("c2").Resize(字典.Count) = Application.Transpose(字典.Keys)   '把不重复值装入到单元格中
  12. End Sub

  14. Sub 求不重复值2()    '不区分大小写
  15.     Sheet2.Range("d2:d12").ClearContents
  16.     字典.CompareMode = TextCompare    '进行文字比较来不区分大小写
  17.     arr = Sheet2.Range("a1:a12").Value
  18.     For i = 1 To UBound(arr)
  19.         字典(arr(i, 1)) = ""           '字典创建关键字
  20.     Next
  21.     Sheet2.Range("d2").Resize(字典.Count) = Application.Transpose(字典.Keys)    '把不重复值装入到单元格中
  22. End Sub

  24. Sub 双向求值()
  25.     arr = Sheet9.Range("a2:b6").Value
  26.     For i = 1 To UBound(arr, 1)
  27.         字典(arr(i, 1)) = arr(i, 2)     '创建城市为关键字，简写为item
  28.         字典(arr(i, 2)) = arr(i, 1)     '创建简写为关键字，城市为item
  29.     Next
  30.     MsgBox 字典(Sheet9.Range("d3").Value)
  31. End Sub

  33. Sub 多条件查找()
  34.     On Error Resume Next
  35.     Dim st As String, st1 As String, st2 As String
  36.     Dim arr1, arr2, arr3
  37.     With Sheet8
  38.         arr = .Range("a2:d5").Value
  39.         For i = 1 To UBound(arr)
  40.             st = arr(i, 1) & "-" & arr(i, 2)     '产品和规格连起来为了创建key
  41.             st1 = arr(i, 3) & "-" & arr(i, 4)    '数量和单价连起来为了创建item
  42.             字典.Add st, st1                     '创建字典key和item
  43.         Next
  44.         arr1 = .Range("a12:b13").Value
  45.         ReDim arr2(1 To 2, 1 To 1)
  46.         ReDim arr3(1 To 2, 1 To 2)
  47.         For i = 1 To UBound(arr1)
  48.             arr2(i, 1) = arr1(i, 1) & "-" & arr1(i, 2)   '查找值合并构成与key一致
  49.             arr3 = VBA.Split(字典.Item(arr2(i, 1)), "-")    '把item的值拆分
  50.             .Range("c" & i + 11).Resize(1, UBound(arr3) + 1).Value = arr3
  51.         Next
  52.     End With
  53. End Sub

  55. Sub 单条件求和()
  56.     With Sheet10
  57.         arr = .Range("b2:c5").Value
  58.         For i = 1 To UBound(arr)
  59.             字典(arr(i, 1)) = 字典(arr(i, 1)) + arr(i, 2)   'key对应的item的值在原来的基础上累加
  60.         Next
  61.         .Range("e2").Resize(字典.Count) = Application.Transpose(字典.Keys)
  62.         .Range("f2").Resize(字典.Count) = Application.Transpose(字典.Items)
  63.     End With
  64. End Sub

  66. Sub 多列求和()
  67.     Dim arr1(1 To 100, 1 To 4)
  68.     Dim irow      '存放key在字典里的行数
  69.     Dim k
  70.     With Sheet12
  71.         arr = .Range("a2:d6").Value
  72.         For i = 1 To UBound(arr)
  73.             If 字典.Exists(arr(i, 1)) Then    '判断每行数据在字典中是否存在
  74.                 irow = 字典(arr(i, 1))        '在字典中的行数
  75.                 arr1(irow, 2) = arr1(irow, 2) + arr(i, 2)     '相同的key把数量相加
  76.                 arr1(irow, 4) = arr1(irow, 4) + arr(i, 4)     '相同的key把金额累加
  77.             Else                                'key在字典中不存在新建key
  78.                 k = k + 1
  79.                 字典(arr(i, 1)) = k
  80.                 arr1(k, 1) = arr(i, 1)
  81.                 arr1(k, 2) = arr(i, 2)
  82.                 arr1(k, 3) = arr(i, 3)
  83.                 arr1(k, 4) = arr(i, 4)
  84.             End If
  85.         Next
  86.         .Range("a13").Resize(k, 4) = arr1
  87.     End With
  88. End Sub

  90. Sub 多条件求和()
  91. Dim arr1(1 To 100, 1 To 4)
  92.     Dim irow      '存放key在字典里的行数
  93.     Dim k, st As String
  94.     With Sheet13
  95.         arr = .Range("a2:d6").Value
  96.         For i = 1 To UBound(arr)
  97.         st = arr(i, 1) & "-" & arr(i, 2)  '把产品和规格连起来作为一个key
  98.             If 字典.Exists(st) Then    '判断每行数据在字典中是否存在
  99.                 irow = 字典(st)        '在字典中的行数
  100.                 MsgBox 字典(st)
  101.                 arr1(irow, 3) = arr1(irow, 3) + arr(i, 3)     '相同的key把数量相加
  102.             Else                                'key在字典中不存在新建key
  103.                 k = k + 1
  104.                 字典(st) = k
  105.                 arr1(k, 1) = arr(i, 1)
  106.                 arr1(k, 2) = arr(i, 2)
  107.                 arr1(k, 3) = arr(i, 3)
  108.             End If
  109.         Next
  110.         .Range("a11").Resize(k, 4) = arr1
  111.     End With
  112. End Sub
复制代码

点评

从从容容
第一题 区分大小写,没有做好,单条件求和,有错误. 多条件求和 有错误.  发表于 2013-11-21 12:26

评分

参与人数 1 +3 金币 +15 收起 理由
从从容容 + 3 + 15 赞一个!

查看全部评分

回复

使用道具 举报

发表于 2013-11-19 15:08 | 显示全部楼层
【VBA字典数组201301班】B07-shanxiren.rar (42.02 KB, 下载次数: 10)

点评

从从容容
多列求和 的"单价"有错,总体不错,但代码还可以优化.希望继续努力,  发表于 2013-11-21 12:31

评分

参与人数 1 +5 金币 +19 收起 理由
从从容容 + 5 + 19 很给力!

查看全部评分

回复

使用道具 举报

下一页 »
12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-20 04:15 , Processed in 0.455040 second(s), 9 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表