提取店名，并根据店名求和

cjc209

Sub 字典汇总()
    Dim arr, brr
    Dim wb As Workbook
    Set d = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
   
    fname = Dir(ThisWorkbook.Path & "\*.xl*")
    Do While fname <> ""
     If InStr(fname, "汇总") = 0 Then
     Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & fname)
     店铺名称l = ActiveSheet.Rows(1).Find(what:="店铺名称", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
     代码l = ActiveSheet.Rows(1).Find(what:="代码", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
     数量l = ActiveSheet.Rows(1).Find(what:="数量", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
     金额l = ActiveSheet.Rows(1).Find(what:="金额", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
     
     arr = ActiveSheet.Range("a1").CurrentRegion '数据装入数组
   
    For i = 1 To UBound(arr)
         tjz = arr(i, 店铺名称l) '条件
            If d.Exists(tjz) Then '字典里存在的时候
                brr = d(tjz) '字典关键字对应的条目的值装入结果数组（可以为数组）
                brr(3) = brr(3) + arr(i, 数量l) '要汇总的列
                brr(4) = brr(4) + arr(i, 金额l) '要汇总的列
            Else
                ReDim brr(1 To 4) '声明动态数组 装符合条件的每列数据
               
                    brr(1) = arr(i, 店铺名称l) '需要的字段装入结果数组
                    brr(2) = arr(i, 代码l)
                    brr(3) = arr(i, 数量l)
                    brr(4) = arr(i, 金额l)
               
            End If
            d(tjz) = brr '更新字典条目中的值
    Next
      wb.Close 0
    End If
        fname = Dir
    Loop
    If d.Count Then
        Sheet2.Range("a1").CurrentRegion.ClearContents '清除结果区的数据
        brr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(d.Items)) '数组装置
        Sheet2.Range("a1").Resize(d.Count, 4) = brr '赋值
    End If
    Application.ScreenUpdating = True
End Sub