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
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
文件格式及要求