ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索

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

热度 1已有 6351 次阅读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
 

文件格式及要求


路过

雷人

握手

鲜花

鸡蛋

发表评论 评论 (1 个评论)

回复 jjmysjg 2022-4-25 01:13
代码的工作表,在哪下载?

facelist

您需要登录后才可以评论 登录 | 免费注册

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-11-15 01:50 , Processed in 0.017186 second(s), 8 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

返回顶部