一个简单的分类汇总方法

 

Sub 分类汇总()
Dim i, j, k As Long
Worksheets(2).Activate
Worksheets(2).Range("A:AZ").Clear
Worksheets(2).Activate
Worksheets(2).Range("A:A").Value = Worksheets(1).Range("A:A").Value
t = Worksheets(2).Cells(1, 1)
Worksheets(2).Cells(1, 1) = 1 & t
S = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row
Worksheets(2).Range(Cells(1, 1), Cells(S, 1)).Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("A2"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range(Cells(2, 1), Cells(S, 1))
        .Apply
    End With
Worksheets(2).Range("A:A").RemoveDuplicates 1
t = Worksheets(2).Cells(1, 1)
Worksheets(2).Cells(1, 1) = Right(t, Len(t) - 1)
S = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets(2).Cells(S, 1) = "合计"
Worksheets(3).Activate
Worksheets(3).Range("A:A").Value = Worksheets(1).Range("B:B").Value
t = Worksheets(3).Cells(1, 1)
Worksheets(3).Cells(1, 1) = 1 & t
S = Worksheets(3).Cells(Rows.Count, 1).End(xlUp).Row
Worksheets(3).Range(Cells(1, 1), Cells(S, 1)).Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("A2"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range(Cells(2, 1), Cells(S, 1))
        .Apply
    End With
Worksheets(3).Range("A:A").RemoveDuplicates 1
Worksheets(2).Activate
For i = 2 To Worksheets(3).Cells(Rows.Count, 1).End(xlUp).Row
Worksheets(2).Cells(1, i).Value = Worksheets(3).Cells(i, 1).Value
Worksheets(2).Cells(1, i + 1) = "合计"
Next
Worksheets(2).Range("A1").CurrentRegion.Select
With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
Worksheets(2).Activate
For i = 2 To Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
If Worksheets(2).Cells(i, 1) = Worksheets(1).Cells(j, 1) Then
For k = 2 To Worksheets(2).Cells(1, Columns.Count).End(xlToLeft).Column
If Worksheets(1).Cells(j, 2) = Worksheets(2).Cells(1, k) Then
t = Worksheets(2).Cells(i, k)
Worksheets(2).Cells(i, k) = Worksheets(1).Cells(j, 3)
S = Worksheets(2).Cells(i, k)
Worksheets(2).Cells(i, k) = S + t
End If
Next
End If
Next
Next
i = Range("A1").CurrentRegion.Rows.Count
For j = 2 To Cells(1, Columns.Count).End(xlToLeft).Column
Cells(i, j) = Application.WorksheetFunction.Sum(Range(Cells(2, j), Cells(i - 1, j)).Value)
Next
i = Range("A1").CurrentRegion.Columns.Count
For j = 2 To Cells(Rows.Count, "A").End(xlUp).Row
Cells(j, i) = Application.WorksheetFunction.Sum(Range(Cells(j, 2), Cells(j, i - 1)).Value)
Next
 Worksheets(2).Range("A1").CurrentRegion.Select
    Selection.Rows.AutoFit
    Selection.Columns.AutoFit
End Sub