VBA(7)字典及常用应用

最新推荐文章于 2024-08-16 09:29:59 发布

之之之之杰

最新推荐文章于 2024-08-16 09:29:59 发布

阅读量1.6w

点赞数 12

分类专栏： VBA 文章标签： microsoft

本文链接：https://blog.csdn.net/q14091355/article/details/125405470

版权

VBA 专栏收录该内容

20 篇文章 10 订阅

订阅专栏

1、字典直接创建

Dim dic as object

Set dic = Createobject("scripting.dictionary")

2、引用法

工具-引用-浏览-scrrun.dll-确定

microsoft scripting runtime 打勾

注：两者在使用上经常用创建多一点；并无太大区别。用创建的字典装入数据后并不能直接用dic.keys(N)/dic.items(N) 的格式来引用字典元素.字典元素从 dic.keys(0)开始

3、字典常用的属性与方法

方法：

.add '创建新的元素

.keys '字典的元素

.items '元素对应的值

.exists '是否存在

.remove '清除提定元素

.removeall '清除所有元素

属性:

.key

.item

.count '统计元素个数

.comparemode'值为1/0/2 文本/英文/数据库格式 '文本格式下不区分大小写

4、基础用法概念

Sub dic1()
    'Dim d As New dictionary                '需工具-引用-microsoft scripting runtime选取后
    Dim d As Object
    Dim arr()
    Dim x%
    Dim m
    Set d = CreateObject("scripting.dictionary")
        d.CompareMode = 1                   '设置为不区分大小写
    [A1:A3] = Application.WorksheetFunction.Transpose(Array("A", "B", "C"))
    [B1:B3] = Application.WorksheetFunction.Transpose(Array(1, 2, 3))
    arr = Range("a1:b3")
    For x = 1 To UBound(arr, 1)
        d(arr(x, 1)) = arr(x, 2)
    Next
    'Stop
    'MsgBox d.keys(2)                       '在本机测试需DIM new dictionary方式下方可用
    [C1:E1] = d.Keys                        '字典keys元素
    [C2:E2] = d.Items                       '字典一个key对应一个Item
    [C3] = d.Count                          '字典D统计元素组个数
    If d.Exists("D") Then                   'Exists查看元素是否存在
        MsgBox "1"
    Else
        'd("D") = 4                          '不存在则增加
        d.Add "D", 4                         'd.add =    d(key)=item
    End If
    Stop                                    '暂停查看字典变化
        d.Key("C") = "5"                     'd.key属性指定元素改变key值
        m = Application.Index(d.Keys, 3)     '用createobject创建的字典用工作表index函数取出赋值
        MsgBox m

    If d.Exists("c") Then                   '前期装入的是"C"。如果不设置区分大小写则不存在
        MsgBox "C存在"
    Else
        d.Remove "b"                        '字典按装入数据的顺序排序
    End If
        d.RemoveAll                        'd.remove 指定keys删除或者Removeall全部
    Stop                                    '暂停查看字典变化
End Sub

5、常见应用:读取数据/去重复/计算/匹配

Sub dic2()  '提取不重复
    Dim d As Object
    Dim arr()
    Dim x As Integer
    Set d = CreateObject("scripting.dictionary")
    d.CompareMode = 1                                                    '设置不分大小写
    [A1:A10] = Application.Transpose(Array("A", "B", "C", "a", "B", "C", "A", "B", "C", "D"))
    [B1:B10] = Application.Transpose(Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10))
    For x = 1 To 10
        d(Cells(x, 1).Value) = Cells(x, 2).Value + d(Cells(x, 1).Value)        '合并相对应累加，相当于SUMIF
        'd.Add Cells(x, 1).Value, Cells(x, 2).Value                      '用add如遇有重复情况会报错
    Next
    Range("d1").Resize(d.Count) = Application.Transpose(d.Keys)         '字典Keys关键字如装入重复则覆盖上一个,利用此特性可去重复,转置输出单元格
    Range("e1").Resize(d.Count) = Application.Transpose(d.Items)        '对应值汇总值输出
    arr = d.Items
    Stop
End Sub
Sub dic3()  '查询匹配
    Dim d As Object
    Dim x%, y%
    Dim arr()
    [A1:A6] = Application.Transpose(Array("A", "B", "C", "a", "d", "D"))
    [B1:B6] = Application.Transpose(Array(1, 2, 3, 4, 5, 6))
        Set d = CreateObject("scripting.dictionary")
        arr = Range("a1:b6")
        For y = 1 To UBound(arr)
            d(arr(y, 1)) = arr(y, 2)            '把双列的数据分别装入1与2列,对应的值相互查询
            d(arr(y, 2)) = arr(y, 1)
        Next
        Stop
    MsgBox d("a") & d(1) & d("A")
End Sub
Sub dic4()  '多列汇总,字典key1列对应item多列
    Dim hrr(1 To 100, 1 To 3)       '定义一个足够大的放汇总数组
    Dim row As Integer
    Dim arr(), x#, k#
    Dim d As Object
    Set d = CreateObject("scripting.dictionary")
    [A1:C1] = Array("品名", "汇总1", "汇总2")   '生成测试用数值
    [A2:C2] = Array("A", "1", "5")
    [A3:C3] = Array("A", "2", "6")
    [A4:C4] = Array("C", "3", "7")
    [A5:C5] = Array("C", "4", "8")
    arr = Range("a2:c" & Range("a65536").End(xlUp).row)
    For x = 1 To UBound(arr)
        If d.Exists(arr(x, 1)) Then         'Exists某个元素在字典中是否存在
            row = d(arr(x, 1))      '如果存在。行数等于字典中的顺序序号
            hrr(row, 2) = hrr(row, 2) + arr(x, 2)       '对应累加
            hrr(row, 3) = hrr(row, 3) + arr(x, 3)       '如果计数将累加数值改1
        Else
            k = k + 1               '如果不存在。记录序号
            d(arr(x, 1)) = k            '装入字典
            hrr(k, 1) = arr(x, 1)           '数组直接装入对应数值
            hrr(k, 2) = arr(x, 2)
            hrr(k, 3) = arr(x, 3)
        End If
        Next
        Range("G2").Resize(k, 3) = hrr      '汇总后结果输出
End Sub
Sub dic5()      '交叉表样式汇总
    Dim hrr(1 To 100, 1 To 4)
    Dim d As Object
    Dim row1&, column1&
    Dim arr(), x#, k#
    Set d = CreateObject("scripting.dictionary")
    [A1:C1] = Array("品名", "月份", "值")
    [A2:C2] = Array("A", "1月", "5")
    [A3:C3] = Array("A", "2月", "6")
    [A4:C4] = Array("C", "3月", "7")
    [A5:C5] = Array("C", "2月", "8")
    arr = Range("a2:c" & Range("a65536").End(xlUp).row)
    For x = 1 To UBound(arr)
        column1 = (InStr("1月2月3月", arr(x, 2)) + 1) / 2 + 1 'InStr（查找的字符串,找什么字符)返回字符所在位置排列的数字
        If d.Exists(arr(x, 1)) Then
            row1 = d(arr(x, 1))
            hrr(row1, column1) = hrr(row1, column1) + arr(x, 3)
        Else
            k = k + 1                       '多行多列汇总值在于确定行数装入，及怎么样区别列值
            d(arr(x, 1)) = k                '需注意列值是单条件还是多条件取值
            hrr(k, 1) = arr(x, 1)
            hrr(k, column1) = arr(x, 3)
        End If
    Next
    Range("f1:h1") = Array("品名/月份", "1月", "2月")
    Range("f2").Resize(k, 3) = hrr
End Sub
Sub dic6()  '指定条件求整余
    Dim d As Object
    Dim x%
    Dim arr()
    Set d = CreateObject("Scripting.Dictionary")
    For x = 1 To 10
        d.Add x & IIf(Abs(x Mod 3) = 0, "@", ""), ""    '循环1至10如果符合则加标识号@
    Next
    arr = WorksheetFunction.Transpose(Filter(d.Keys, "@"))  '筛选只有标识号的值
    [A1].Resize(UBound(arr), 1) = arr                       '筛选完之后输出单元格"3@,6@,9@"
    [A:A].Replace "@", ""                                   '替代掉标识符
    Set d = Nothing                                         '关闭字典
End Sub
Sub dic7()      '指定类型分类并提取不重复
    Dim str1$, str2$, str3$
    Dim nRow%, d As Object
    Dim Brr(), arr
    Dim s(1 To 4) As Integer, i%
    Set d = CreateObject("scripting.dictionary")
    str1 = Join(Array("类型1A", "类型1B", "类型1C"), ",")      '定义类型1，以数组形式储存
    str2 = Join(Array("种类2A", "种类2B", "种类2C"), ",")      '定义类型2，以数组形式储存
    str3 = Join(Array("型3A", "型3B", "型3C"), ",")      '定义类型3，以数组形式储存
    nRow = Range("a1").End(xlDown).row
    arr = Range("a1:a" & nRow)                          '数据源装入
    ReDim Brr(1 To nRow, 1 To 4)                        '筛选后放置数组
    For i = 2 To nRow                                       '遍历数据源
        If Not d.Exists(arr(i, 1)) Then                         '如果数据不存在执行
            d(arr(i, 1)) = ""                                  '放入字典
            If str1 Like "*" & Left(arr(i, 1), 2) & "*" Then'类型文本1中有跟遍历值相像的话
                s(1) = s(1) + 1                                 '记录类型1列的行累加
                Brr(s(1), 1) = arr(i, 1)                            '赋值给1列
            ElseIf str2 Like "*" & Left(arr(i, 1), 2) & "*" Then
                s(2) = s(2) + 1
                Brr(s(2), 2) = arr(i, 1)
            ElseIf str3 Like "*" & Left(arr(i, 1), 2) & "*" Then
                s(3) = s(3) + 1
                Brr(s(3), 3) = arr(i, 1)
            Else
                s(4) = s(4) + 1                               '都与123类型不类似的放入第4列
                Brr(s(4), 4) = arr(i, 1)                        '记录4列的行累加
            End If
        End If
    Next
    [K1:N1] = Array("类型1", "种类2", "型3", "其他")
    Range("k2:n" & nRow) = Brr                              '输出结果到单元格
End Sub