绑定dictionary 给定关键字不再字典中_VBA字典

·        创建字典对象 ' 后期绑定：方便代码在其他电脑上运行，推荐。 dim dic as object Set dic =CreateObject("scripting.dictionary")   ' 前期绑定：可以直接声明字典对象，有对象属性和方法的提示，但在其他没有勾选引用的电脑上无法正常运行。 ' 引用勾选：VBE窗体-工具-引用-勾选‘Microsoft Scripting Runtime’ dim dic as New dictionary ·        获取字典的键、值，字典计数，删除，判断键是否存在于字典 with activesheet         'dic.count ：字典计数，字典中一共有多少条记录；         'dic.keys ：字典的键，写入单元格以行写入，如需以列写入单元格，调用工作表函数transpose转置；         .cells(1,1).resize(dic.count,1)= application.worksheetfunction.transpose(dic.keys)         ' 清除工作表单元格内容         .cells.clearcontents                 'dic.items ：字典的值；         .cells(1,1).resize(1,dic.count)= dic.items           ' 判断某内容是否存在与字典的键中         ifdic.exists(" 内容")then debug.print "字符串‘内容’存在于字典的键中"                 ' 清空字典，有时候其他过程也需要使用字典，当前过程已经使用完了，但我们又不想重新创建字典对象，这时候我们可以public字典全局变量，再清空字典，供新的过程使用该字典对象。         dic.removeall         ' 清除单个字典键-值对,key是字典的某个需要删除的键         dic.removekey end with ·        字典常用方法 1.     去重 dim dic as object dim arr dim st Set dic =CreateObject("scripting.dictionary")   arr = array(" 可乐","雪碧","鸡翅",,"可乐","汉堡包","鸡翅") for each st in arr         ' 字典的键是不能重复的，重复导入字典只会存在一个，可以利用字典这点特性去重。         ' 这里不需要字典的值，设置为空字符串或其他数值都可以。         dic(st)= "" next activesheet.range("a1").resize(dic.count,1)= application.worksheetfunction.transpose(d.keys) 2.     实现 sumifs 条件求和 Sub dic_sumif() Application.ScreenUpdating = False Dim dic As Object Dim arr Dim i As Byte   Set dic = CreateObject("scripting.dictionary") With ActiveSheet    arr = .UsedRange    For i = 2 To UBound(arr)         'dic(arr(i,1)) 没有值是默认是0，通过下面方法对每一个水果的销量进行累加。        dic(arr(i, 1)) = dic(arr(i, 1)) + arr(i, 2)    Next     ' 使用copy方法，将表头复制到e1，f1单元格    .Range("a1:b1").Copy .Range("e1")     ' 字典键去重纵向写入到单元格    .Cells(2, "e").Resize(dic.Count, 1) =Application.WorksheetFunction.Transpose(dic.keys)    For i = 2 To dic.Count + 1         ' 循环输入字典键对应的值到f列        .Cells(i, "f").Value2 = dic(.Cells(i, "e").Value2)    Next End With set dic = Nothing Application.ScreenUpdating = True End Sub ·          效果如下图： 3. 计数 如果对上面水果种类进行计数： countifs ，只需要将分类汇总的值改为数值 1 即可，每出现一次 ‘+1’ dic(arr(i, 1)) = dic(arr(i, 1)) + 1   ' 在上面代码中添加下这条，修改下表头 range("f1").value2 = " 计数" 效果如下图： 4. 匹配 ·        这个应该是使用字典应用最多的了，需要注意的是，如果使用单元格写入到字典，单元格同时也包含格式等信息，如果只需要单元格的值，要使用单元格 .value2 方法，同时，字典的值也可以是数组。 ·        数据源： ·        目标：匹配 ‘ 李白 ’ 和 ‘ 后羿 ’ 的身高和体重 ·        代码如下： Sub data_match() Application.ScreenUpdating = False Dim dic As Object Dim arr Dim i As Byte   Set dic = CreateObject("scripting.dictionary") With ActiveSheet    arr = .Cells(1, 1).CurrentRegion    For i = 2 To UBound(arr)         ' 这里字典的值，用的是array数组，方便我们一下匹配多个数据，省去再创建字典对象麻烦。        dic(arr(i, 1)) = Array(arr(i, 2), arr(i, 3))    Next    For i = 2 To .Cells(1, "e").End(xlDown).row         .Cells(i, "f").Resize(1, 2) =dic(.Cells(i, "e").Value2)    Next End With set dic = Nothing Application.ScreenUpdating = True End Sub 效果如下： 我在这里加入了 ‘ 妲己 ’ ，遍历用字典去匹配了，但是字典并没有 ‘ 妲己 ’ 这个 key ，匹配出来是空，并没有报错，大家不用担心字典没有对应 key 匹配而出错这种情况，这样只会将结果输出为空。 ~ 如果需要匹配的姓名后面有之前填写的身高和体重信息，但是载入字典的数据源并没有这个人的信息，我们在遍历匹配时，又不想使身高和体重被替换为空，这时候可以结合 dic.exisst 语句，判断姓名是否存在于字典的 keys 中，再输出匹配结果。 5. key 的组合和分割 dim arr dim i,row as long dim d as object dim key   set d =createobject("scripting.dictionary") with thisworkbook         arr= .sheets(1).usedrange         fori = 2 to ubound(arr)                d(join(array(arr(i,1),arr(i,2),arr(i,3)),"|"))= arr(i,4)         next                 with.sheets(" 输出")                row= 2                foreach key in d.keys                        .cells(row,4).value= d(key)                        .cells(row,1).resize(1,3)= split(key,"|")                        row= row + 1                next         endwith end with 6.     字典多字段累加 Sub game_type_active_pay() Dim file_directory, f As String Dim i, last_row As Long Dim d As Object Dim wb As Workbook Dim arr Dim active_uv, pay_uv As Long Dim pay As Double Application.ScreenUpdating = False   file_directory = ThisWorkbook.Path &"/data/" f = Dir(file_directory & "* 细分品类*") ' 未找到数据源，提示，关闭应用 If f = "" Then    MsgBox " 未找到命名包含‘细分品类’文字数据源，请先下载数据源......"    Application.ScreenUpdating = True    End End If   Set wb = Workbooks.Open(file_directory& f) Set d = CreateObject("scripting.dictionary") arr = ActiveSheet.UsedRange 'On Error Resume Next For i = 2 To UBound(arr)    If InStr(" 回流用户|留存用户|新增用户",arr(i, 4)) > 0 Then        If arr(i, 3) = " 类型1" Then arr(i, 3) = "类型2"             '将类型1合并为类型2        If d.exists(arr(i, 1) & "|" & arr(i, 3)) Then            active_uv = d(arr(i, 1) & "|" & arr(i, 3))(0)            pay_uv = d(arr(i, 1) & "|" & arr(i, 3))(1)            pay = d(arr(i, 1) & "|" & arr(i, 3))(2)            ' 活跃累加            active_uv = active_uv + arr(i, 6)             pay_uv = pay_uv + arr(i, 7)            pay = pay + arr(i, 8)            d(arr(i, 1) & "|" & arr(i, 3)) = Array(active_uv,pay_uv, pay)        Else            d(arr(i, 1) & "|" & arr(i, 3)) = Array(arr(i, 6),arr(i, 7), arr(i, 8))        End If    End If Next 'On Error GoTo 0 wb.Close False Set wb = Nothing MsgBox d.Count   With ThisWorkbook.Sheets(" 表名")    arr = .UsedRange    For i = 2 To UBound(arr)        If d.exists(arr(i, 1) & "|" & arr(i, 2)) Then            ' 如果新的数据源里存在该条记录，则用新的数据源覆盖            .Cells(i, 3).Resize(1, 3) = d(arr(i, 1) & "|" & arr(i,2))            .Cells(i, 6).Value2 = .Cells(i, 5).Value2 / .Cells(i, 3).Value2            d.Remove arr(i, 1) & "|" & arr(i, 2)        End If    Next    last_row = .Cells(Rows.Count, 1).End(xlUp).Row + 1     ' 将新的记录写入到数据源    For Each Key In d.keys        .Cells(last_row, 1).Resize(1, 2) = Split(Key, "|")        .Cells(last_row, 3).Resize(1, 3) = d(Key)        .Cells(last_row, 6).Value2 = .Cells(i, 5).Value2 / .Cells(i, 3).Value2        last_row = last_row + 1    Next End With   Application.ScreenUpdating = True End Sub ·        字典求和和计数同时进行 Sub test() Dim d As Object Dim key_cnt As Long Dim key As String   Det d =CreateObject("scripting.dictionary") arr = ActiveSheet.UsedRange For i = 2 To UBound(arr)    key = Join(Array(arr(i, 2), arr(i, 3)), "|")     ' 如果字典该条键存在，累加    If d.exists(key) Then        key_cnt = d(key)(0) + 1    ' 天数，计数+1        val_sum = d(key)(1) + arr(i, 4)     ' 指标值加总        d(key) = Array(key_cnt, val_sum)    Else        ' 如果不存在，计数计算为1        d(key) = Array(1, arr(i, 4))    End If Next End Sub