根据某列中字符自动归类并添加分类名称并添加公式

lchqfly

根据B列的 名称 带“集中器” 的归为 甲供设备，其余归为 甲供材料，并自动增加 黄色部分excel的公式（重要这个是只填充计算公式不要直接填充计算结果，要公式），附件里 已经手工处理好表格，下面的代码是坛朋友 xiangbaoan  给的，归类功能已实现，黄色部分不是填充计算公式，而是填充计算结果，望大师再帮忙改改
Option Explicit
Sub test()'简化一下
Dim sh As Worksheet, ar, i&, j&, k&, y&, p&
For Each sh In Worksheets
     ar = sh.Range("a5:k" & sh.Cells(Rows.Count, 2).End(xlUp).Row)
     ReDim br(1 To UBound(ar) + 2, 1 To UBound(ar, 2))
     k = 1
     p = UBound(br) - 1
     For i = 1 To UBound(ar) - 1
         For j = 7 To 8
             ar(i, j + 2) = ar(i, j) - ar(i, j - 2)
         Next
         If InStr(ar(i, 2), "集中器") = 0 Then
             k = k + 1
             br(k, 1) = k - 1
             y = k
         Else
             y = p
             br(p, 1) = UBound(br) - p
             p = p - 1
         End If
         For j = 2 To UBound(ar, 2)
             br(y, j) = ar(i, j)
         Next
     Next
     k = UBound(br)
     For i = 2 To p - 1
         For j = 6 To 10 Step 2
             br(1, j) = br(1, j) + br(i, j)
         Next
     Next
     For i = p + 1 To k - 1
         For j = 6 To 10 Step 2
             br(p, j) = br(p, j) + br(i, j)
         Next
     Next
     For j = 6 To 10 Step 2
         br(k, j) = br(1, j) + br(p, j)
     Next
     br(1, 1) = "一"
     br(1, 2) = "甲供材料"
     br(p, 1) = "二"
     br(p, 2) = "甲供设备"
     br(k, 2) = "合计"
'    sh.Range("a5").Resize(k, UBound(br, 2)) = br
     sh.[b65536].End(3)(2, 2).Resize(k, UBound(br, 2)) = br
Next
End Sub