用VBA汇总结果保存总表 粉红色单元格

xiangbaoan

Option Explicit
Sub test()
Dim d, Arr(), Brr, ws As Worksheet, r&, c%, st$, m%, n%
Set d = CreateObject("scripting.dictionary")
For Each ws In Worksheets
    If ws.Name <> "總表" Then
        With ws
            Brr = .Range("a3:f" & .Cells(Rows.Count, 1).End(xlUp).Row)
            For r = 1 To UBound(Brr)
                st = Brr(r, 1) & Brr(r, 2)
                If st <> "" Then
                    If d.exists(st) Then
                        m = d(st)
                        For c = 3 To 6
                            Arr(c, m) = Arr(c, m) + Brr(r, c)
                        Next
                    Else
                        n = n + 1
                        d(st) = n
                        ReDim Preserve Arr(1 To 6, 1 To n)
                        For c = 1 To 6
                            Arr(c, n) = Brr(r, c)
                        Next
                    End If
                End If
            Next
        End With
    End If
Next
With Worksheets("總表")
    .[a1].CurrentRegion.Offset(2) = ""
    .[a3].Resize(n, 6) = Application.Transpose(Arr)
End With
Set d = Nothing
End Sub'补充：汇总名称是固定了的吧?我理解有误，追问再回

xiangbaoan

'前面可能理解错误，若不是就请试试这个
Sub test()
Dim d, Arr(), Brr, Crr, Drr, ws As Worksheet, r&, c%, st$, m%, n%
Set d = CreateObject("scripting.dictionary")
With Worksheets("總表")
    .[a1].CurrentRegion.Offset(2, 2).Resize(, 4) = ""
    Crr = .Range("a3:f" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
For Each ws In Worksheets
    If ws.Name <> "總表" Then
        With ws
            Brr = .Range("a3:f" & .Cells(Rows.Count, 1).End(xlUp).Row)
        End With
        For r = 1 To UBound(Brr)
            st = Brr(r, 1) & Brr(r, 2)
            If st <> "" Then
                If d.exists(st) Then
                    m = d(st)
                    For c = 3 To 6
                        Arr(c, m) = Arr(c, m) + Brr(r, c)
                    Next
                Else
                    n = n + 1
                    d(st) = n
                    ReDim Preserve Arr(1 To 6, 1 To n)
                    For c = 1 To 6
                        Arr(c, n) = Brr(r, c)
                    Next
                End If
            End If
        Next
    End If
Next
d.RemoveAll
Drr = Application.Transpose(Arr)
For r = 1 To UBound(Drr)
   d(Drr(r, 1) & Drr(r, 2)) = r
Next
For r = 1 To UBound(Crr)
    n = d(Crr(r, 1) & Crr(r, 2))
    For c = 3 To 6
        Crr(r, c) = Drr(n, c)
    Next
Next
Worksheets("總表").[a3].Resize(UBound(Crr), UBound(Crr, 2)) = Crr
Set d = Nothing
End Sub

xiangbaoan

laoau128 发表于 2017-3-28 19:57
可能会不断增加吧， 固定不固定也没有所谓

若自动汇总所有的 名称及规格 用第1段；若要汇总指定的 名称及规格(可指定任意个)可用第2段。