自动添加行并计算小计与合计

衣欣不xi

能否写一段代码由原始信息自动得到这里的处理结果？
我的难点是手工操作的定位条件不知道如何通过代码来表示，或是有什么别的方式来达到这种效果？
里面我录制了一段宏，但录制的宏我不知道怎么改写

蓝桥玄霜

请见代码。

yaozong

1. Sub test()
   
2.   Application.ScreenUpdating = False
   
3.   Sheets("处理结果2").Activate
   
4.   Dim d, arr, ke, i, j, k, m, n, s, ss
   
5.   Set d = CreateObject("Scripting.Dictionary")
   
6.   arr = Sheets("原始信息").[a1].CurrentRegion.Value
   
7.   m = UBound(arr): n = UBound(arr, 2)
   
8.   For i = 2 To m
   
9.     d(arr(i, 2)) = ""
   
10.   Next
    
11.   ReDim brr(1 To m + d.Count, 1 To n)
    
12.   For Each ke In d.keys
    
13.     For i = 2 To m
    
14.       If arr(i, 2) = ke Then
    
15.         k = k + 1
    
16.         s = s + arr(i, 4)
    
17.         For j = 1 To n
    
18.           brr(k, j) = arr(i, j)
    
19.         Next
    
20.       End If
    
21.     Next
    
22.     brr(k + 1, 2) = "小计"
    
23.     brr(k + 1, 4) = s
    
24.     k = k + 1
    
25.     ss = ss + s
    
26.     s = 0
    
27.   Next
    
28.   brr(k + 1, 2) = "合计"
    
29.   brr(k + 1, 4) = ss
    
30.   [a2].CurrentRegion.Offset(1).ClearContents
    
31.   [a2].Resize(k + 1, n) = brr
    
32.   Application.ScreenUpdating = True
    
33. End Sub

复制代码

yaozong

参考附件               160113-aaa.rar (14.18 KB, 下载次数: 565)

2016-1-13 09:55 上传

点击文件名下载附件

衣欣不xi

yaozong 发表于 2016-1-13 09:54

谢谢，我已试用，试用是没有问题，但里面的代码好复杂，我对数组运用还不熟悉，想问问不用数组跟字典能解决吗？

yaozong

衣欣不xi 发表于 2016-1-13 23:29
谢谢，我已试用，试用是没有问题，但里面的代码好复杂，我对数组运用还不熟悉，想问问不用数组跟字典能解 ...

不用字典与数组也可以，直接操作单元格，速度差一点。

Sub yy() ''操作单元格/插入式
  Application.ScreenUpdating = False
  Dim i&, k&, r&
  Sheets("处理结果3").Activate
  Sheets("原始信息").Cells.Copy [A1]
  [A1].CurrentRegion.Sort Key1:=[B2], Order1:=1, Key2:=[A2], Order2:=1, Header:=xlYes
  r = [b65536].End(3).Row + 1
  Cells(r, 2) = "合计"
  Cells(r, 4) = Application.Sum([d2].Resize(r))
  Cells(r, 1).Resize(1, 5).Borders.LineStyle = 1
  i = 2: k = 1
  Do While Cells(i, 2) <> "合计"
    If Cells(i, 2).Value = Cells(i + 1, 2).Value Then
       k = k + 1
    Else
      Cells(i + 1, 2).EntireRow.Insert
      Cells(i + 1, 2) = "小计"
      Cells(i + 1, 4) = "=SUM(R[-" & k & "]C:R[-1]C)"
      i = i + 1: k = 1
    End If
    i = i + 1
  Loop
  Application.ScreenUpdating = True
End Sub

yaozong

参考附件            160114-aaa.rar (19.13 KB, 下载次数: 291)

2016-1-14 08:50 上传

点击文件名下载附件

JJMY

yaozong 发表于 2016-1-14 08:51
参考附件

真是高不可攀呀。

lgw7758

这个数据透视表就能完成了吧？

bajifeng

不用字典

1. Sub ba()    'bajifeng
   
2. Columns("a:e").Sort [b1], 1, Header:=xlYes
   
3. i = 2
   
4. Do
   
5.     If Cells(i, 2) = Cells(i + 1, 2) Then
   
6.         my = my + Cells(i, 4)
   
7.         i = i + 1
   
8.     Else
   
9.         my = my + Cells(i, 4)
   
10.         Cells(i + 1, 1).EntireRow.Insert
    
11.         Cells(i + 1, 2) = "小计"
    
12.         Cells(i + 1, 4) = my
    
13.         i = i + 2：n = 0: my = 0
    
14.     End If
    
15. Loop While Cells(i, 4) <> ""
    
16. End Sub

复制代码