求请教如何把某列中内容相同的行放在一起，并附加个小计，类似于筛选的那种，用VBA...

大神小文

就像在工作表中的内容按照产品类型进行分类（如sheet1），然后每个类型下一行加一个求和的小计（如sheet2），哪位VB大神帮帮忙

LMY123

排序并插入小计行

大神小文

LMY123 发表于 2018-4-13 12:46
排序并插入小计行

代码该这么写呢，实际工作的表里产品类型巨多，一个个弄的话还是很麻烦

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, k, sum, total, n
  With Sheets("sheet1")
    arr = .Range("a2:f" & .Cells(Rows.Count, "c").End(xlUp).Row + 1)
  End With
  ReDim brr(1 To UBound(arr, 1) * 2, 1 To UBound(arr, 2))
  Call bsort(arr, 3)
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      sum = sum + arr(j, 6)
      n = n + 1
      For k = 1 To UBound(arr, 2): brr(n, k) = arr(j, k): Next
      If arr(j, 3) <> arr(j + 1, 3) Then
        n = n + 1
        brr(n, 1) = "小计": brr(n, 6) = sum
        total = total + sum: sum = 0
        i = j: Exit For
      End If
  Next j, i
  n = n + 1: brr(n, 1) = "总计": brr(n, 6) = total
  With Sheets("sheet2").[a2]
    .Resize(Rows.Count - 1, UBound(brr, 2)).ClearContents
    .Resize(n, UBound(brr, 2)) = brr
  End With
End Sub

Function bsort(arr, key)
  Dim i, j, k, t, move As Boolean
  For i = LBound(arr, 1) To UBound(arr, 1) - 2
    For j = LBound(arr, 1) To UBound(arr, 1) + LBound(arr, 1) - 2 - i
        If arr(j, key) > arr(j + 1, key) Then
          For k = LBound(arr, 2) To UBound(arr, 2)
            t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
          Next
          move = True
        End If
      Next
    If Not move Then Exit For
  Next
End Function

大神小文

一把小刀闯天下 发表于 2018-4-13 13:07
Option Explicit

Sub test()

大佬您再帮我看看，小弟愚笨做不到举一反三，和上一个附件类似，将表一里的数据分别按照 产品类型 产品型号 产品项目号生成三张表，给销售收入和成本加小计，感激不尽

ncq666

一把小刀闯天下 发表于 2018-4-13 13:07
Option Explicit

Sub test()

学习了，太棒了，只是很多语句还没读懂

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr, zrr()
   
4.   Application.ScreenUpdating = False
   
5.   Application.DisplayAlerts = False
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     .Range("a1:f" & r).Sort key1:=.Range("c2"), order1:=xlAscending, Header:=xlYes
   
9.     xm = ""
   
10.     arr = .Range("c1:c" & r)
    
11.     For i = 2 To UBound(arr)
    
12.       If arr(i, 1) <> xm Then
    
13.         m = m + 1
    
14.         ReDim Preserve zrr(1 To 2, 1 To m)
    
15.         zrr(1, m) = i
    
16.         zrr(2, m) = i
    
17.         xm = arr(i, 1)
    
18.       Else
    
19.         zrr(2, m) = i
    
20.       End If
    
21.     Next
    
22.     For k = UBound(zrr, 2) To 1 Step -1
    
23.       .Rows(zrr(2, k) + 1).Insert
    
24.       .Cells(zrr(2, k) + 1, 1) = "小计"
    
25.       .Cells(zrr(2, k) + 1, 6).FormulaR1C1 = "=SUM(R" & zrr(1, k) & "C:R" & zrr(2, k) & "C)"
    
26.     Next
    
27.   End With
    
28. End Sub
    

复制代码

chxw68

练练手。。。