求助VBA实现从一工作簿逐个工作表查找对应值返回到另一汇总工作薄

Sub 汇总()
    Dim i&, j%, x%, y%, z%
    Dim ddate As Object, ddh As Object, dzz As Object
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set ddate = CreateObject("scripting.dictionary")
    Set ddh = CreateObject("scripting.dictionary")
    Set dzz = CreateObject("scripting.dictionary")
    Workbooks.Open Filename:=ThisWorkbook.Path & "\原数据工作簿.xlsx"
    For j = 1 To Worksheets.Count
        Set sht = Sheets(j)
        ddh(sht.Name) = ""
        For i = 2 To sht.Cells(1, Columns.Count).End(1).Column
            idate = DateValue(sht.Cells(1, i))
            ddate(idate) = ""     '日期
            aa = sht.Name & idate
            dzz(aa) = dzz(aa) + sht.Cells(13, i).Value
        Next
    Next
    ActiveWindow.Close
    arr = dzz.keys: brr = dzz.items
    Cells = "": [a1] = "代号": Cells.Borders.LineStyle  = 0
    Range("B1").Resize(1, ddate.Count) = ddate.keys
    Range("a2").Resize(ddh.Count, 1) = Application.Transpose(ddh.keys)
    xr = Cells(Rows.Count, 1).End(3).Row
    cr = Cells(1, Columns.Count).End(1).Column
    Range(Cells(1, 1), Cells(xr, cr)).Borders.LineStyle = xlContinuous
    For x = 2 To xr
        For y = 2 To cr
            For z = 0 To dzz.Count - 1
                If Cells(x, 1) & Cells(1, y) = arr(z) Then
                    Cells(x, y) = brr(z)
                End If
            Next
        Next
    Next
    Set ddate = Nothing
    Set ddh = Nothing
    Set dzz = Nothing
    Application.ScreenUpdating = True
End Sub

以上代码只对单薄多表

效果详见附件http://yunpan.cn/Qtr4dWZAgvssR

为什么不增加一个工作表，把汇总汇总做上去，弄成一个工作薄，那样方便很多，打开工作薄有点费时间。不过也可以完成