一个复杂的多表汇总，请大神帮忙

liulang0808

1823824221 发表于 2020-2-21 09:16
最后一个工作表里多了一个汇总， 如果我把这三个工作表里都加上那个汇总，怎么改代码，麻烦帮我看看

楼主具体描述下，要在这里增加汇总，最后的模拟结果是什么样子的

1823824221

liulang0808 发表于 2020-2-21 13:53
楼主具体描述下，要在这里增加汇总，最后的模拟结果是什么样子的

Sub 按钮1_Click()
    Dim crr()
    Set d = CreateObject("scripting.dictionary")
    Set dd = CreateObject("scripting.dictionary")
    Set fso = CreateObject("scripting.filesystemobject")

    Application.ScreenUpdating = False
    For Each f In fso.getfolder(ThisWorkbook.Path).Files
        If InStr(f.Name, "每日报表") = 0 Then
            With Workbooks.Open(f)
                arr = .Sheets(1).UsedRange
                .Close False
            End With
            d.RemoveAll
            dd.RemoveAll
            For j = 2 To UBound(arr)
                If Len(arr(j, 2)) > 0 Then
                    str1 = Left(arr(j, 7), 2) & "@#$@" & arr(j, 2) & "@#$@" & arr(j, 3) & "@#$@" & arr(j, 4)
                    d(str1) = d(str1) + arr(j, 5)
                    dd(str1) = dd(str1) + arr(j, 6)
                End If
            Next j
            
            For Each sht In ThisWorkbook.Sheets
                brr = Split(sht.Name, "、")
                ReDim crr(1 To d.Count, 1 To 5)
                r = 0
                For x = 0 To d.Count - 1
                    
                    str1 = d.keys()(x)
                    For Z = 0 To UBound(brr)
                        If Left(str1, 2) = brr(Z) Then
                            arr = Split(str1, "@#$@")
                            r = r + 1
                            crr(r, 1) = arr(1)
                            crr(r, 2) = arr(2)
                            crr(r, 3) = arr(3)
                            crr(r, 4) = d(str1)
                            crr(r, 5) = dd(str1)
                        End If
                    Next Z
                Next x
                For i = 1 To r
                    For j = i + 1 To r
                        If crr(j, 5) > crr(i, 5) Then
                        For x = 1 To 5
                            tmp = crr(i, x)
                            crr(i, x) = crr(j, x)
                            crr(j, x) = tmp
                        Next x
                        End If
                    Next j
                Next i
                If r > 0 Then
                    nm = Left(f.Name, 2)
                    If nm = "总店" Then
                        sht.[b4].Resize(WorksheetFunction.Min(r, 15), 5) = crr
                    Else
                        For x = 8 To sht.UsedRange.Columns.Count Step 6
                            ww = Left(sht.Cells(2, x), 2)
                            If ww = nm Then
                                sht.Cells(4, x).Resize(WorksheetFunction.Min(r, 15), 5) = crr
                                Exit For
                            End If
                        Next
                    End If
                End If
            Next sht
            
        End If
    Next f
    Application.ScreenUpdating = True
End Sub
今天又加了两个类别，如果01、09    我要加15开头，    就是01、09、15         。05、11、12  要加上14 类别  ，改成05、11、12、14  请问代码改哪里

1823824221

chxw68 发表于 2020-2-21 11:19
主观臆断，把问题想复杂了。

格式还是发生了改变。

chxw68

1823824221 发表于 2020-2-22 16:49
格式还是发生了改变。

不明白你说的问题，代码供参考吧。

1823824221

chxw68 发表于 2020-2-22 17:04
不明白你说的问题，代码供参考吧。

您的这个表头的位置发生的变化 。

chxw68

1823824221 发表于 2020-2-23 09:00
您的这个表头的位置发生的变化 。

这些结果表格都是根据原始表格数据全新生成的，可以自动适应店铺的增减，所以顺序也是根据原始数据先后排列的，如果有特别要求，可以指定顺序，然后在代码里进行调整。