【代码】更新：科目余额表逐级汇总，工作表Change事件，自动刷新汇总数据；Application.EnableEvents属性
文摘
教育
2024-10-09 23:19
江苏
1、在工作表“科目余额表”里，命令按钮点击事件，工作表Change事件，调用汇总过程：Private Sub CmdSum_Click() Call mySumByLevelEnd Sub
Private Sub Worksheet_Change(ByVal Target As Range) Dim rng As Range, lRow As Long, lCol As Long Application.ScreenUpdating = False lRow = UsedRange.Rows.Count lCol = 3 Set rng = Cells(2, 1).Resize(lRow, 3) If Not Application.Intersect(rng, Target) Is Nothing Then Application.EnableEvents = False Call mySumByLevel Application.EnableEvents = True End If Application.ScreenUpdating = TrueEnd Sub
2、在myModule里，mySumByLevel逐级汇总过程：第一部分：把数据装入数组，标记科目是否末级，存入字典（这段基本没变，定义了一个cell变量）：Sub mySumByLevel() '//定义变量 Dim i As Integer, j As Integer, total As Double Dim ws As Worksheet, lRow As Integer, lCol As Integer, rng As Range, cell As Range Dim dic As Object, dkey, dkey1, dkey2 Dim arr() '//对象赋值 Set ws = ThisWorkbook.Sheets("科目余额表") Set dic = CreateObject("Scripting.Dictionary") '//把数据装入数组 With ws lRow = .UsedRange.Rows.Count lCol = 3 Set rng = .Cells(1, 1).Resize(lRow, 3) arr = rng.Value End With '//把数据装入字典，item统一赋值TRUE，意为“末级科目” For i = 2 To lRow dkey = arr(i, 1) If dkey <> "" Then dic(dkey) = True End If Next '//把非末级科目，在字典中的item改为False '//通过两层循环比对，针对当前科目代码，如果找到一个包含当前科目代码的科目代码， '//则可以断定，当前科目代码为非末级科目代码 For Each dkey1 In dic.keys For Each dkey2 In dic.keys If dkey1 <> dkey2 And InStr(dkey2, dkey1) > 0 Then dic(dkey1) = False Exit For End If Next Next '//输入到工作表临时查看结果 ws.Cells(2, 5).Resize(dic.Count) = Application.Transpose(dic.keys) ws.Cells(2, 6).Resize(dic.Count) = Application.Transpose(dic.items)
第二部分：循环数组arr，汇总非末级科目，结果回写到工作表（在第4行增加了一个dkey1<>""的判断，避免A列空白单元格也进行汇总，增加了单元格格式设置） '//循环数组，对非末级科目进行汇总，规则是开头是此非末级科目的所有末级科目汇总 For i = 2 To lRow dkey1 = arr(i, 1) If Not dic(dkey1) And dkey1 <> "" Then total = 0 For j = 2 To lRow dkey2 = arr(j, 1) If dkey1 <> dkey2 And dic(dkey2) And InStr(dkey2, dkey1) = 1 Then total = total + arr(j, 3) End If Next arr(i, 3) = total End If Next '//把数据写入工作表，设置单元格格式 With rng .Columns(1).NumberFormat = "@" .Columns(3).NumberFormat = "_ * #,##0.00_ ;_ * -#,##0.00_ ;_ * ""-""??_ ;_ @_ " .Value = arr For Each cell In .Columns(1).Cells With cell.Resize(1, 3) If Not dic(cell.Value) And cell.Row > 1 Then .Interior.Color = RGB(255, 250, 240) .Font.Bold = True Else .Interior.Color = xlNone .Font.Bold = False End If End With Next End WithEnd Sub
![]()
| 安利小店
安利的牙膏非常不错，用了以后就不想再用其他的了；洗洁精、洗衣液也是日常必备，用过都说好！ |
![]()
| 合谷医疗
合谷医疗专攻各种疑难杂症，尤其擅长抑郁症、焦虑失眠、儿童神经发育异常、多动症、自闭孤独症、腰颈椎疾病治疗，可谓神乎其技！体验过的直呼早点来就好了！ |
喜欢就点个赞、点在看、留言评论、分享一下呗！感谢支持！
