分类汇总统计不知咋弄了

小石头936

各位大师，本人学习用VBA做个分类汇总统计表，弄了一点儿就不会了，求帮助。具体如下：
这是准备统计的基础表，想要按工具和班组进行分类统计。目前只实现了单个工具按班组的统计， ，想要在“刀片合计”行后面继续统计其他工具的内容，达到类似下表的目标。 前面实现刀片统计功能用的代码如下：
For Each ra In Sheets("个人消耗").Columns("A").SpecialCells(2)
    If Columns("k").Find(ra) Is Nothing Then [k65536].End(3).Offset(1) = ra
Next

For j = 3 To Sheets("个人消耗").[k60000].End(xlUp).Row
            For k = 3 To Sheets("个人消耗").[A60000].End(xlUp).Row
              If Sheets("个人消耗").Cells(j, 11).Value = Sheets("个人消耗").Cells(k, 1).Value Then
                    If Trim(Sheets("个人消耗").Cells(k, 3).Value) = "刀片" Then                       
                        total = total + Sheets("个人消耗").Cells(k, 5).Value
                        totaljia = totaljia + Sheets("个人消耗").Cells(k, 7).Value
                        ztotal = ztotal + Sheets("个人消耗").Cells(k, 5).Value
                        ztotaljia = ztotaljia + Sheets("个人消耗").Cells(k, 7).Value
                    End If
              End If
            Next
                 If total > 0 Then
                    Sheets(name1).Cells(m, 1).Value = m - 2
                    Sheets(name1).Cells(m, 2).Value = Sheets("个人消耗").Cells(j, 11).Value
                    Sheets(name1).Cells(m, 3).Value = "刀片"
                    Sheets(name1).Cells(m, 4).Value = total
                    Sheets(name1).Cells(m, 5).Value = totaljia
                    Sheets(name1).Cells(m, 5).NumberFormatLocal = "0.0_ "
                    m = m + 1
                    total = 0
                    totaljia = 0
                  End If
       Next
       Sheets(name1).Cells(m, 1) = "刀片合计"
       Sheets(name1).Cells(m, 4) = ztotal
       Sheets(name1).Cells(m, 5) = ztotaljia

现在想要继续增加后续的工具统计，不会了，诚意求解，刚开始学，代码简陋，望勿讽。

xyxcc177

传你的附件

opiona

小计合计总计排序  请前往322楼：http://club.excelhome.net/thread-859194-1-1.html

不知道为什么

数组和字典配合就可以了

小石头936

谢谢各位老师的提示，通过数组和字典先进行了汇总，然后通过录制宏，实现了分类汇总，目标已实现。只是拷贝了录制的宏，总觉得没用用自己的代码实现，觉得应该还会有更清晰的方法。方便的话，还请指点！ 另外还存在一个问题：     当检测到已生成目标表单后，将原表内容全部删除，然后再设置标题，        Sheets(name1).Range(Cells(1, 1), Cells(1, 4)).HorizontalAlignment = xlCenterAcrossSelection         '该设置第一行标题跨行居中语句提示1004问题       为何？如何解决？       Sub 按工具汇总()  Dim brr(1 To 3000, 1 To 4) Dim arr1, x, hs As Integer, sr As String, k, j As Integer Set d = CreateObject("scripting.dictionary") j = Sheets("个人消耗").[a30000].End(xlUp).Row Sheets("个人消耗").Select arr1 = Sheets("个人消耗").Range(Cells(2, 1), Cells(j, 8)) For x = 1 To UBound(arr1)   sr = Trim(arr1(x, 1)) & Trim(arr1(x, 3)) If arr1(x, 5) <> 0 Or arr1(x, 5) <> "" Then   If d.exists(sr) Then      hs = d(sr)      brr(hs, 3) = brr(hs, 3) + arr1(x, 5)      brr(hs, 4) = brr(hs, 4) + arr1(x, 7)   Else      k = k + 1      d(sr) = k      brr(k, 1) = arr1(x, 3)      brr(k, 2) = arr1(x, 1)      brr(k, 3) = arr1(x, 5)      brr(k, 4) = arr1(x, 7)    End If  End If Next x name1 = "分类统计（按工具）" For i = 1 To Worksheets.Count     If Worksheets(i).Name = name1 Then         biuldbook = False         Exit For     Else         biuldbook = True     End If Next If biuldbook = True Then ThisWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = name1         Sheets(name1).Cells(1, 1) = Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1) & name1         Sheets(name1).Cells(1, 1).Font.Size = 16         Sheets(name1).Range(Cells(1, 1), Cells(1, 4)).HorizontalAlignment = xlCenterAcrossSelection         Rows("1:1").RowHeight = 28.5         Sheets(name1).Columns("B:D").ColumnWidth = 12         Sheets(name1).Columns("A").ColumnWidth = 21         Sheets(name1).Cells(2, 1) = "工具名称"         Sheets(name1).Cells(2, 2) = "班组"         Sheets(name1).Cells(2, 3) = "数量"         Sheets(name1).Cells(2, 4) = "价值" Else     For i = 1 To 20000         Sheets(name1).Rows(i).Clear     Next         Sheets(name1).Cells(1, 1) = Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1) & name1         Sheets(name1).Cells(1, 1).Font.Size = 16 '        Sheets(name1).Range(Cells(1, 1), Cells(1, 4)).HorizontalAlignment = xlCenterAcrossSelection '该设置第一行标题跨行居中语句提示1004问题         Rows("1:1").RowHeight = 28.5         Sheets(name1).Columns("B:D").ColumnWidth = 12         Sheets(name1).Columns("A").ColumnWidth = 21         Sheets(name1).Cells(2, 1) = "工具名称"         Sheets(name1).Cells(2, 2) = "班组"         Sheets(name1).Cells(2, 3) = "数量"         Sheets(name1).Cells(2, 4) = "价值" Sheets(name1).Select Selection.ClearOutline End If  Sheets(name1).Range("a3").Resize(k, 4) = brr  Sheets(name1).Range(Cells(2, 1), Cells(Sheets(name1).[a10000].End(xlUp).Row, 4)).Select     Sheets(name1).Sort.SortFields.Clear     Sheets(name1).Sort.SortFields.Add Key:=Sheets(name1).Range(Cells(2, 1), Cells(Sheets(name1).[a10000].End(3).Row, 1)) _         , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal     With Sheets(name1).Sort         .SetRange Sheets(name1).Range(Cells(2, 1), Cells(Sheets(name1).[d10000].End(3).Row, 4))         .Header = xlYes         .MatchCase = False         .Orientation = xlTopToBottom         .SortMethod = xlPinYin         .Apply     End With Sheets(name1).Range(Cells(2, 1), Cells(Sheets(name1).[a10000].End(xlUp).Row, 4)).Select    Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(3, 4), _         Replace:=True, PageBreaks:=False, SummaryBelowData:=True         Sheets(name1).Range(Cells(2, 1), Cells(Sheets(name1).[a30000].End(xlUp).Row, 4)).Select                     With Selection                        .HorizontalAlignment = xlCenter                        .VerticalAlignment = xlCenter                        .Borders.LineStyle = 1                        .RowHeight = 22                     End With  End Sub

小石头936

谢谢各位老师的提示，通过数组和字典结合汇总，然后通过录制宏，实现了分类汇总，目标已实现。只是拷贝了录制的宏，总觉得没用用自己的代码实现，觉得应该还会有更清晰的方法。方便的话，还请指点！
另外还存在一个问题：
    当检测到已生成目标表单后，将原表内容全部删除，然后再设置标题，
       Sheets(name1).Range(Cells(1, 1), Cells(1, 4)).HorizontalAlignment = xlCenterAcrossSelection
        '该设置第一行标题跨行居中语句提示1004问题
      为何？如何解决？
   


Sub 按工具汇总()

Dim brr(1 To 3000, 1 To 4)
Dim arr1, x, hs As Integer, sr As String, k, j As Integer
Set d = CreateObject("scripting.dictionary")
j = Sheets("个人消耗").[a30000].End(xlUp).Row
Sheets("个人消耗").Select
arr1 = Sheets("个人消耗").Range(Cells(2, 1), Cells(j, 8))
For x = 1 To UBound(arr1)
  sr = Trim(arr1(x, 1)) & Trim(arr1(x, 3))
If arr1(x, 5) <> 0 Or arr1(x, 5) <> "" Then
  If d.exists(sr) Then
     hs = d(sr)
     brr(hs, 3) = brr(hs, 3) + arr1(x, 5)
     brr(hs, 4) = brr(hs, 4) + arr1(x, 7)
  Else
     k = k + 1
     d(sr) = k
     brr(k, 1) = arr1(x, 3)
     brr(k, 2) = arr1(x, 1)
     brr(k, 3) = arr1(x, 5)
     brr(k, 4) = arr1(x, 7)
   End If
End If
Next x
name1 = "分类统计（按工具）"
For i = 1 To Worksheets.Count
    If Worksheets(i).Name = name1 Then
        biuldbook = False
        Exit For
    Else
        biuldbook = True
    End If
Next
If biuldbook = True Then
ThisWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = name1
        Sheets(name1).Cells(1, 1) = Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1) & name1
        Sheets(name1).Cells(1, 1).Font.Size = 16
        Sheets(name1).Range(Cells(1, 1), Cells(1, 4)).HorizontalAlignment = xlCenterAcrossSelection
        Rows("1:1").RowHeight = 28.5
        Sheets(name1).Columns("B:D").ColumnWidth = 12
        Sheets(name1).Columns("A").ColumnWidth = 21
        Sheets(name1).Cells(2, 1) = "工具名称"
        Sheets(name1).Cells(2, 2) = "班组"
        Sheets(name1).Cells(2, 3) = "数量"
        Sheets(name1).Cells(2, 4) = "价值"
Else
    For i = 1 To 20000
        Sheets(name1).Rows(i).Clear
    Next
        Sheets(name1).Cells(1, 1) = Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1) & name1
        Sheets(name1).Cells(1, 1).Font.Size = 16
'        Sheets(name1).Range(Cells(1, 1), Cells(1, 4)).HorizontalAlignment = xlCenterAcrossSelection
'该设置第一行标题跨行居中语句提示1004问题
        Rows("1:1").RowHeight = 28.5
        Sheets(name1).Columns("B:D").ColumnWidth = 12
        Sheets(name1).Columns("A").ColumnWidth = 21
        Sheets(name1).Cells(2, 1) = "工具名称"
        Sheets(name1).Cells(2, 2) = "班组"
        Sheets(name1).Cells(2, 3) = "数量"
        Sheets(name1).Cells(2, 4) = "价值"
Sheets(name1).Select
Selection.ClearOutline
End If

Sheets(name1).Range("a3").Resize(k, 4) = brr

Sheets(name1).Range(Cells(2, 1), Cells(Sheets(name1).[a10000].End(xlUp).Row, 4)).Select
    Sheets(name1).Sort.SortFields.Clear
    Sheets(name1).Sort.SortFields.Add Key:=Sheets(name1).Range(Cells(2, 1), Cells(Sheets(name1).[a10000].End(3).Row, 1)) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sheets(name1).Sort
        .SetRange Sheets(name1).Range(Cells(2, 1), Cells(Sheets(name1).[d10000].End(3).Row, 4))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
Sheets(name1).Range(Cells(2, 1), Cells(Sheets(name1).[a10000].End(xlUp).Row, 4)).Select
   Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(3, 4), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
        Sheets(name1).Range(Cells(2, 1), Cells(Sheets(name1).[a30000].End(xlUp).Row, 4)).Select
                    With Selection
                       .HorizontalAlignment = xlCenter
                       .VerticalAlignment = xlCenter
                       .Borders.LineStyle = 1
                       .RowHeight = 22
                    End With

End Sub