liulang0808

https://club.excelhome.net/?238368

提取文件夹下不同文件不同表格内容到一个表格汇总（字典使用的一个案例说明）

热度 1已有 6370 次阅读2013-12-30 13:54

Sub aaa()
   Set d1 = CreateObject("scripting.dictionary")
   Set d2 = CreateObject("scripting.dictionary")
.....
For Each key In d1
    d2(d1(key)) = key
Next key
End Sub

以上代码的思想来自论坛 amanda7019

Sub Macro1()
    Dim i As Integer, d1 As Object, d2 As Object
    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    For i = 1 To 9
        d2("a" & i) = "b" & i
    Next
    For i = 1 To 9
        l1 = d2.Keys()(i - 1)
        d1("c" & i) = d2.Keys()(i - 1) ' "a" & i
    Next
    For i = 0 To d1.Count - 1
        MsgBox d2(d1.Items()(i))
    Next
End Sub

以上代码是论坛赵版的杰作，留存学习。

注意，在取用单元格内容作为字典keys值的时候，要么赋值给变量然后给字典使用，要么直接使用value

如：dic（cells(1,1))是要有问题的，正确应该是dic(cells(1,1).value)或者设置变量y=cells（1,1）,然后dic(y)

1、字典使用的一个小说明

Sub aaa()
    Set dic1 = CreateObject("scripting.dictionary")
    dic1("1o") = 1
    dic1("2o") = 2
    dic1("2o") = 6 + dic1("2o")
    dic1("3o") = 6

y="3o"

   if dic1.exists(y) then "可以判断是否存在该值了"
    arr = dic1.items‘将字典存储的值赋值给数组变量。
    a1 = arr(2)，字典的第三个值，即dic1("3o")

End Sub

2、具体汇总不同文件不同表格内容的代码

Sub test()
Application.ScreenUpdating = False
    a = 4
    Set dic1 = CreateObject("scripting.dictionary") '存储各个表格里的姓名
    Set dic2 = CreateObject("scripting.dictionary") '存储各个表格姓名对应的单元格的值，如果相同就累加
    Set fso = CreateObject("scripting.filesystemobject")
    Set ff = fso.getfolder(ThisWorkbook.Path) '
    For Each f In ff.Files '打开当前文件下所有文件，如果有非excel文件需要特殊处理下

        If f.Name <> ThisWorkbook.Name Then '打开的文件非本宏程序所在的文件。
            Workbooks.Open f '打开搜索到的文件
            For j = 1 To Workbooks(f.Name).Sheets.Count '遍历打开文件的每一张表格
                rng = Workbooks(f.Name).Sheets(j).UsedRange?将表格已用区域内容赋值给rng
                a1 = Workbooks(f.Name).Sheets(j).Cells(Rows.Count, 1).End(3).Row - 1 '需要读取数据的最大行号
                str1 = Workbooks(f.Name).Sheets(j).Name
                For i = 4 To a1
                    y1 = str1 & rng(i, 1) '存储用户名，用表名+姓名的方式保存，可以过滤重复
                    dic1(y1) = y1
                    For k = 2 To 8 '提取表内数据到字典里，如果有相同的就进行累加
                        y2 = str1 & rng(i, 1) & rng(3, k) '字典的关键字采用：表名+姓名+项目的方式
                        dic2(y2) = dic2(y2) + rng(i, k)
                    Next k
                Next i
            Next j
        Workbooks(f.Name).Close
        End If
    Next f
        arr = dic1.items '将字典中的内容赋值给数组
        For k = 0 To dic1.Count - 1 '从数组中提取每张表中的姓名
            str2 = Left(arr(k), 5)
            ThisWorkbook.Sheets(str2).Cells(Rows.Count, 1).End(3).Offset(1, 0) = Right(arr(k), Len(arr(k)) - 5)
        Next k
    For j = 1 To ThisWorkbook.Sheets.Count '将字典中的值赋值到表格里
        For k = 4 To ThisWorkbook.Sheets(j).Cells(Rows.Count, 1).End(3).Row
            For i = 2 To 8
                y2 = ThisWorkbook.Sheets(j).Name & ThisWorkbook.Sheets(j).Cells(k, 1) & ThisWorkbook.Sheets(j).Cells(3, i)
                ThisWorkbook.Sheets(j).Cells(k, i) = dic2(y2)
            Next i
        Next k
    Next j
Application.ScreenUpdating = True

End Sub