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

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 String
    
    fil = Dir(ThisWorkbook.Path & "\*.xls*")
    Do While fil <> ""
        ak(i) = fil
        i = i + 1
        fil = Dir
    Loop

Set wba = ThisWorkbook
Set shta = wba.Worksheets(1)
shta.Range("A2:A3000").ClearContents
shta.Range("C2:A3000").ClearContents
shta.Range("D2:A3000").ClearContents

i = 0
j = 2
For Each file In ak
    i = i + 1
    If Trim(file) <> "程序文件.xlsm" And Trim(file) <> "~$程序文件.xlsm" And Trim(file) <> "" Then
        str1 = Split(file, ".")
        sname = str1(0)
        shta.Cells(j, 1) = sname
        shta.Cells(j, 1).Select
        'Selection = fso.GetBaseName(file)
        folder_location = ThisWorkbook.Path & "\" & file
        shta.Hyperlinks.Add anchor:=Selection, Address:=folder_location
        With Selection.Font
        .Size = 14
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
        End With
        j = j + 1
    End 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 String
    
    fil = Dir(ThisWorkbook.Path & "\*.xls*")
    Do While fil <> ""
        ak(i) = fil
        i = i + 1
        fil = Dir
    Loop
    
Set wba = ThisWorkbook
Set shta = wba.Worksheets(1)

For Each file In ak
Application.DisplayAlerts = False
Application.ScreenUpdating = False

    If Trim(file) <> "" And Trim(file) <> "程序文件.xlsm" Then
        Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & file)
        Set sht = wb.Worksheets(1)
        snum = 0
        gint = 2
        For j = 2 To 2000
             If Trim(sht.Cells(j, 1)) <> "" Then
                 sht.Cells(j, 8) = CInt(sht.Cells(j, 4)) - CInt(sht.Cells(j, 5)) - CInt(sht.Cells(j, 6))
                 snum = sht.Cells(j, 8) + snum
             ElseIf Trim(sht.Cells(j, 1)) = "" Then
                sht.Range("K2") = snum
                    For ji = 2 To 2000
                            If 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) Then
                                        dic.Item(strname) = CDbl(dic(strname)) + CDbl(sht.Cells(ji, 14).Value)
                                    Else
                                        dic.Item(strname) = CDbl(sht.Cells(ji, 14).Value)
                                    End If
                            Else
                            Exit For
                            End If
                    Next ji
                Exit For
                
             End If
             
        Next j
        wb.Save
        wb.Close
    End If
    

Application.DisplayAlerts = True
Application.ScreenUpdating = True
    
Next
shta.Range("C2:C5000").ClearContents
shta.Range("D2:D5000").ClearContents

shta.Range("C2").Resize(dic.Count) = Application.Transpose(dic.keys)
shta.Range("D2").Resize(dic.Count) = Application.Transpose(dic.items)
End Sub