EXCEL通过VBA字典的方式将各个分表的数据经过计算后显示在总表中

Sub 按钮1_Click()
Dim wba As Workbook
Dim shta As Worksheet
Dim ak(1 To 2000) As String
i = 1
Dim fil As Stringfil = Dir(ThisWorkbook.Path & "\*.xls*")Do While fil <> ""ak(i) = fili = i + 1fil = DirLoopSet wba = ThisWorkbook
Set shta = wba.Worksheets(1)
shta.Range("A2:A3000").ClearContents
shta.Range("C2:A3000").ClearContents
shta.Range("D2:A3000").ClearContentsi = 0
j = 2
For Each file In aki = i + 1If Trim(file) <> "程序文件.xlsm" And Trim(file) <> "~$程序文件.xlsm" And Trim(file) <> "" Thenstr1 = Split(file, ".")sname = str1(0)shta.Cells(j, 1) = snameshta.Cells(j, 1).Select'Selection = fso.GetBaseName(file)folder_location = ThisWorkbook.Path & "\" & fileshta.Hyperlinks.Add anchor:=Selection, Address:=folder_locationWith Selection.Font.Size = 14.Strikethrough = False.Superscript = False.Subscript = False.OutlineFont = False.Shadow = False.TintAndShade = 0.ThemeFont = xlThemeFontNoneEnd Withj = j + 1End If
Next
'wba.Save
End Sub
Sub 汇总()
Dim wba As Workbook
Dim shta As Worksheet
Dim wb As Workbook
Dim sht As Worksheet
Dim snum As Long
Dim ak(1 To 2000) As String
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
i = 1
Dim fil As Stringfil = Dir(ThisWorkbook.Path & "\*.xls*")Do While fil <> ""ak(i) = fili = i + 1fil = DirLoopSet wba = ThisWorkbook
Set shta = wba.Worksheets(1)For Each file In ak
Application.DisplayAlerts = False
Application.ScreenUpdating = FalseIf Trim(file) <> "" And Trim(file) <> "程序文件.xlsm" ThenSet wb = Workbooks.Open(ThisWorkbook.Path & "\" & file)Set sht = wb.Worksheets(1)snum = 0gint = 2For j = 2 To 2000If Trim(sht.Cells(j, 1)) <> "" Thensht.Cells(j, 8) = CInt(sht.Cells(j, 4)) - CInt(sht.Cells(j, 5)) - CInt(sht.Cells(j, 6))snum = sht.Cells(j, 8) + snumElseIf Trim(sht.Cells(j, 1)) = "" Thensht.Range("K2") = snumFor ji = 2 To 2000If Trim(sht.Cells(ji, 12)) <> "" And Trim(sht.Cells(ji, 13)) <> "" Then '股东姓名sht.Cells(ji, 14) = CDbl(sht.Range("K2")) * CDbl(sht.Cells(ji, 13))strname = Trim(sht.Cells(ji, 12))If dic.Exists(strname) Thendic.Item(strname) = CDbl(dic(strname)) + CDbl(sht.Cells(ji, 14).Value)Elsedic.Item(strname) = CDbl(sht.Cells(ji, 14).Value)End IfElseExit ForEnd IfNext jiExit ForEnd IfNext jwb.Savewb.CloseEnd IfApplication.DisplayAlerts = True
Application.ScreenUpdating = TrueNext
shta.Range("C2:C5000").ClearContents
shta.Range("D2:D5000").ClearContentsshta.Range("C2").Resize(dic.Count) = Application.Transpose(dic.keys)
shta.Range("D2").Resize(dic.Count) = Application.Transpose(dic.items)
End Sub