迷你记账系统制作：[9]科目余额汇总表生成

 Excel 2003

 VBA

制作一个如图所示日期范围选择窗体。

ALT+F11打开VBE编辑器，新建一个用户窗体，名称改为：日期范围，caption属性改为：日期范围，其他属性如图示。

利用工具箱上的框架控件，拖拉生成一个框架，名称设为：Frame1，caption属性改为：输入日期范围，其他属性如图。

利用文本框控件，分别拖拉出2个文本框，名称分别改为：yff，yfl，Text和Value属性分别皆设为1，其他属性如图示。

利用滚动条控件，分别拖拉出2个微调按钮，名称分别设为：sbf、sbl，LargeChange和SmallChange属性分别皆设为1，Max属性分别皆设为1，Min属性分别皆设为12，其他属性如图示。

利用命令按钮控件分别拖拉出2个按钮，名称分别设为：CommandButton1、CommandButton2，caption属性分别设为：确认、退出，其他属性如图示。

在日期范围窗体代码窗口，粘贴如下代码：Private Sub CommandButton1_Click()Dim f As Boolean, yfh As Byte, yfq As Byte, lrow As IntegerDim i As Integer, h As Integer, flag As Boolean, flag1 As BooleanDim rg As Range, rg1 As Rangeflag = Falseflag1 = Falsef = Falseyfq = Val(yff.Value)yfh = Val(yfl.Value)If Sheets(5).CommandButton4.Caption = '明细科目取消组合' Then Sheets(5).Outline.ShowLevels RowLevels:=3 Sheets(5).CommandButton4.Caption = '明细科目组合' h = Sheets(5).Range('a65536').End(xlUp).Row For i = 5 To h  If Len(Cells(i, 1)) > 3 Then   If flag Then    Set rg = Union(rg, Rows(i))   Else    Set rg = Rows(i)    flag = True   End If  Else   If flag Then    rg.Ungroup    flag = False   End If  End If  If Len(Cells(i, 1)) > 5 Then   If flag1 Then    Set rg1 = Union(rg1, Rows(i))   Else    Set rg1 = Rows(i)    flag1 = True   End If  Else   If flag1 Then    rg1.Ungroup    flag1 = False   End If  End If Next i If flag Then rg.Ungroup If flag1 Then rg1.UngroupEnd IfIf yfq > yfh Thenf = MsgBox('月份输入不合法，请重新输入', vbExclamation + vbOKOnly, '输入非法，警告！')ElseIf yfq < Month(Sheets(4).Range('a2').Value) Thenf = MsgBox('请选择建帐后的月份', vbExclamation + vbOKOnly, '月份非法，警告！')End IfIf f = False ThenIf yfh = yfq ThenSheets(5).Range('a2') = '2014年' & yfh & '月'ElseSheets(5).Range('a2') = '2014年' & yfq & '月' & '-' & yfh & '月'End Iflrow = Sheets(5).Range('a65536').End(xlUp).Row + 1Sheets(5).Range('a5:j' & lrow).ClearContentsSheets(5).Range('a5:j' & lrow).Borders.LineStyle = xlNoneCall kmyehz(yff.Value, yfl.Value)Call qcyescCall qmyescCall pxCall gsyhUnload MeEnd IfEnd Sub Private Sub CommandButton2_Click()Unload MeEnd SubPrivate Sub sbf_Change()yff.Value = sbf.ValueEnd SubPrivate Sub sbl_Change()yfl.Value = sbl.ValueEnd Sub

在Sheet4（科目余额汇总表）代码窗口，粘贴如下代码：Private Sub CommandButton1_Click()日期范围.ShowEnd Sub

在自定义函数过程模块，粘贴如下代码：Sub kmyehz(yff As Byte, yfl As Byte) '科目余额汇总，yff开始月份，yfl结束月份Dim d As New Dictionary, d1 As New Dictionary, d2 As New DictionaryDim d3 As New Dictionary, d4 As New DictionaryDim d33 As New Dictionary, d44 As New DictionaryApplication.ScreenUpdating = Falseh = Sheets(1).Range('a65536').End(xlUp).Rowarr = Sheets(1).Range('a3:b' & h)For i = 1 To UBound(arr) '将科目及期初余额设定表中的科目代码及科目名称装入字典dd(arr(i, 1)) = arr(i, 2)Nexth = Sheets(4).Range('b65536').End(xlUp).Rowarr = Sheets(4).Range('a2:i' & h) '将凭证总表中的数据装入数组arrFor i = 1 To UBound(arr) If Month(arr(i, 1)) >= yff And Month(arr(i, 1)) <= yfl Then '满足月份条件，借贷金额装入相应字典  If Len(arr(i, 5)) = 3 Then '如果为一级科目则将该科目对应科目代码分别装入d1,d2,借方及贷方金额分别装入对应科目代码字典d1，d2   d1(arr(i, 5)) = d1(arr(i, 5)) + arr(i, 8)   d2(arr(i, 5)) = d2(arr(i, 5)) + arr(i, 9)  ElseIf Len(arr(i, 5)) = 5 Then '如果为二级科目则将该科目对应一,二级科目代码分别装入d1,d2,借方及贷方金额分别装入对应科目代码字典d1,d2   d1(Val(Left(arr(i, 5), 3))) = d1(Val(Left(arr(i, 5), 3))) + arr(i, 8)   d1(arr(i, 5)) = d1(arr(i, 5)) + arr(i, 8)   d2(Val(Left(arr(i, 5), 3))) = d2(Val(Left(arr(i, 5), 3))) + arr(i, 9)   d2(arr(i, 5)) = d2(arr(i, 5)) + arr(i, 9)  ElseIf Len(arr(i, 5)) = 7 Then '如为三级科目则将对应一,二,三,级科目分别对应装入d1,d2   d1(Val(Left(arr(i, 5), 3))) = d1(Val(Left(arr(i, 5), 3))) + arr(i, 8)   d1(Val(Left(arr(i, 5), 5))) = d1(Val(Left(arr(i, 5), 5))) + arr(i, 8)   d1(arr(i, 5)) = d1(arr(i, 5)) + arr(i, 8)   d2(Val(Left(arr(i, 5), 3))) = d2(Val(Left(arr(i, 5), 3))) + arr(i, 9)   d2(Val(Left(arr(i, 5), 5))) = d2(Val(Left(arr(i, 5), 5))) + arr(i, 9)   d2(arr(i, 5)) = d2(arr(i, 5)) + arr(i, 9)  End If End IfNextFor i = 1 To UBound(arr) '当月借贷有发生科目,则截止当月借贷累计金额装入相应字典d3,d4 If d1.Exists(arr(i, 5)) And Month(arr(i, 1)) <= yfl Then  If Len(arr(i, 5)) = 3 Then   d3(arr(i, 5)) = d3(arr(i, 5)) + arr(i, 8)   d4(arr(i, 5)) = d4(arr(i, 5)) + arr(i, 9)  ElseIf Len(arr(i, 5)) = 5 Then   d3(Val(Left(arr(i, 5), 3))) = d3(Val(Left(arr(i, 5), 3))) + arr(i, 8)   d3(arr(i, 5)) = d3(arr(i, 5)) + arr(i, 8)   d4(Val(Left(arr(i, 5), 3))) = d4(Val(Left(arr(i, 5), 3))) + arr(i, 9)   d4(arr(i, 5)) = d4(arr(i, 5)) + arr(i, 9)  ElseIf Len(arr(i, 5)) = 7 Then   d3(Val(Left(arr(i, 5), 3))) = d3(Val(Left(arr(i, 5), 3))) + arr(i, 8)   d3(Val(Left(arr(i, 5), 5))) = d3(Val(Left(arr(i, 5), 5))) + arr(i, 8)   d3(arr(i, 5)) = d3(arr(i, 5)) + arr(i, 8)   d4(Val(Left(arr(i, 5), 3))) = d4(Val(Left(arr(i, 5), 3))) + arr(i, 9)   d4(Val(Left(arr(i, 5), 5))) = d4(Val(Left(arr(i, 5), 5))) + arr(i, 9)   d4(arr(i, 5)) = d4(arr(i, 5)) + arr(i, 9)  End If End IfNextFor i = 1 To d1.Count '按照d1,d2字典科目代码顺序调整d3,d4字典 d33(d1.Keys(i - 1)) = d3(d1.Keys(i - 1)) d44(d2.Keys(i - 1)) = d4(d2.Keys(i - 1))NextFor i = 1 To d1.Count '根据科目代码输出对应科目名称至科目余额汇总表相应位置 Sheets(5).Cells(i + 4, 1) = d1.Keys(i - 1) Sheets(5).Cells(i + 4, 2) = d(d1.Keys(i - 1))NextSheets(5).Range('e5').Resize(d1.Count) = Application.Transpose(d1.Items)Sheets(5).Range('f5').Resize(d2.Count) = Application.Transpose(d2.Items)Sheets(5).Range('g5').Resize(d33.Count) = Application.Transpose(d33.Items)Sheets(5).Range('h5').Resize(d44.Count) = Application.Transpose(d44.Items)Application.ScreenUpdating = TrueEnd Sub Sub px() '科目余额汇总表按科目代码排序Dim arr, arr1(1 To 10)Dim hApplication.ScreenUpdating = Falseh = Sheets(5).Range('a65536').End(xlUp).Rowarr = Sheets(5).Range('a5:j' & h)For i = 1 To UBound(arr) For j = i + 1 To UBound(arr)  If Val(Left(arr(i, 1), 3)) > Val(Left(arr(j, 1), 3)) Then   For x = 1 To 10    arr1(x) = arr(i, x)    arr(i, x) = arr(j, x)    arr(j, x) = arr1(x)   Next x  ElseIf Val(Left(arr(i, 1), 3)) = Val(Left(arr(j, 1), 3)) Then   If Len(arr(i, 1)) > Len(arr(j, 1)) Then    If Len(arr(j, 1)) = 3 Then     For x = 1 To 10      arr1(x) = arr(i, x)      arr(i, x) = arr(j, x)      arr(j, x) = arr1(x)     Next x    ElseIf Len(arr(j, 1)) = 5 Then     If Val(Left(arr(i, 1), 5)) >= arr(j, 1) Then      For x = 1 To 10       arr1(x) = arr(i, x)       arr(i, x) = arr(j, x)       arr(j, x) = arr1(x)      Next x     End If    End If   ElseIf Len(arr(i, 1)) = Len(arr(j, 1)) Then    If arr(i, 1) > arr(j, 1) Then     For x = 1 To 10      arr1(x) = arr(i, x)      arr(i, x) = arr(j, x)      arr(j, x) = arr1(x)     Next x    End If   Else    If Len(arr(i, 1)) = 5 Then     If arr(i, 1) > Val(Left(arr(j, 1), 5)) Then      For x = 1 To 10       arr1(x) = arr(i, x)       arr(i, x) = arr(j, x)       arr(j, x) = arr1(x)      Next x     End If    End If   End If  End If Next j Sheets(5).Range('a5').Resize(UBound(arr), 10) = arrNext iApplication.ScreenUpdating = TrueEnd Sub Sub qcyesc() '期初余额生成Dim d As New Dictionary, d1 As New Dictionary, d2 As New DictionaryDim arr, arr1, h As Integer, hb As Integer, m As Byte, n As ByteApplication.ScreenUpdating = Falseh = Sheets(5).Range('a65536').End(xlUp).Rowarr = Sheets(5).Range('a5:b' & h) '将科目余额汇总表数据装入数组arrIf InStr(Sheets(5).Range('a2').Value, '-') Then '取当前月份 m = Val(Month(Split(Sheets(5).Range('a2').Value, '-')(0)))Else m = Val(Month(Sheets(5).Range('a2').Value))End IfIf m - 1 Then '不是1月 hb = Sheets(6).Cells(65536, (m - 1) * 4 + 1).End(xlUp).Row If hb > 2 Then '上一个月末存在备份数据  arr1 = Sheets(6).Range(Sheets(6).Cells(3, (m - 1) * 4 + 1), Sheets(6).Cells(hb, (m - 1) * 4 + 4)) '将上月末备份数据装入数组arr1 Else  hb = Sheets(6).Range('a65536').End(xlUp).Row  arr1 = Sheets(6).Range('a3:d' & hb) '将期初备份数据装入数组arr1 End IfElse hb = Sheets(6).Range('a65536').End(xlUp).Row arr1 = Sheets(6).Range('a3:d' & hb) '当前为1月将期初备份数据装入数组arr1End IfFor i = 1 To UBound(arr) '初始化字典数据 d(arr(i, 1)) = '平' '字典d初始化装入科目代码,余额方向初始为平 d1(arr(i, 1)) = 0 '字典d1初始化装入科目代码,初始余额为0 d2(arr(i, 1)) = arr(i, 2) '字典d2初始化装入科目代码,科目名称Next iFor i = 1 To UBound(arr1) '将arr1中数据写入字典 d(arr1(i, 1)) = arr1(i, 3) d1(arr1(i, 1)) = arr1(i, 4) d2(arr1(i, 1)) = arr1(i, 2)Next iSheets(5).Range('a5').Resize(d.Count) = Application.Transpose(d.Keys)Sheets(5).Range('b5').Resize(d.Count) = Application.Transpose(d2.Items)Sheets(5).Range('c5').Resize(d.Count) = Application.Transpose(d.Items)Sheets(5).Range('d5').Resize(d1.Count) = Application.Transpose(d1.Items)Application.ScreenUpdating = TrueEnd Sub Sub qmyesc() '期末余额生成Dim d As New DictionaryDim arr, h As Integer, arr1, hzh As IntegerApplication.ScreenUpdating = Falseh = Sheets(1).Range('a65536').End(xlUp).Rowarr = Sheets(1).Range('a3:c' & h)For i = 1 To UBound(arr) d(arr(i, 1)) = arr(i, 3) '将科目及期初余额设定表中的科目代码、余额方向存入字典Next ihzh = Sheets(5).Range('a65536').End(xlUp).Rowarr1 = Sheets(5).Range('a5:j' & hzh)For i = 1 To UBound(arr1) If d(arr1(i, 1)) = '借' Then '科目对应的余额方向为借  arr1(i, 10) = arr1(i, 4) + arr1(i, 5) - arr1(i, 6)  If arr1(i, 10) = 0 Then   arr1(i, 9) = '平'  Else   arr1(i, 9) = '借'  End If ElseIf d(arr1(i, 1)) = '贷' Then '科目对应的余额方向为贷  arr1(i, 10) = arr1(i, 4) + arr1(i, 6) - arr1(i, 5)  If arr1(i, 10) = 0 Then   arr1(i, 9) = '平'  Else   arr1(i, 9) = '贷'  End If End IfNext iSheets(5).Range('a5').Resize(UBound(arr1), 10) = arr1Application.ScreenUpdating = TrueEnd Sub Sub gsyh()Dim arr, arr1(1 To 1000, 1 To 10)Dim h As Integer, i As Integer, j As Byte, k As IntegerApplication.ScreenUpdating = Falsek = 1h = Sheets(5).Range('a65536').End(xlUp).Rowarr = Sheets(5).Range('a5:j' & h) '将科目余额汇总表装入数组arrFor i = 1 To UBound(arr) For j = 4 To 10  If arr(i, j) = '' Then arr(i, j) = 0 '将空单元格值改为0 Next jNext iFor i = 1 To UBound(arr) If arr(i, 5) <> 0 Or arr(i, 6) <> 0 Or arr(i, 10) <> 0 Then '将借贷发生额或期末余额不为0的行放入arr1中  For x = 1 To 10   arr1(k, x) = arr(i, x)  Next x  k = k + 1 Else  If i < UBound(arr) Then   If InStr(arr(i + 1, 1), arr(i, 1)) Then    For x = 1 To 10     arr1(k, x) = arr(i, x)    Next x    k = k + 1   End If  End If End IfNext iFor i = 1 To k - 1 If Len(arr1(i, 1)) = 3 Then  If arr1(i, 3) = '借' Then   arr1(k, 4) = arr1(k, 4) + arr1(i, 4)  ElseIf arr1(i, 3) = '贷' Then   arr1(k + 1, 4) = arr1(k + 1, 4) + arr1(i, 4)  End If  arr1(k, 5) = arr1(k, 5) + arr1(i, 5)  arr1(k, 7) = arr1(k, 7) + arr1(i, 7)  arr1(k + 1, 6) = arr1(k + 1, 6) + arr1(i, 6)  arr1(k + 1, 8) = arr1(k + 1, 8) + arr1(i, 8)  If arr1(i, 9) = '借' Then   arr1(k, 10) = arr1(k, 10) + arr1(i, 10)  ElseIf arr1(i, 9) = '贷' Then   arr1(k + 1, 10) = arr1(k + 1, 10) + arr1(i, 10)  End If End IfNext iarr1(k, 2) = '借方合计'arr1(k, 3) = '借'If arr1(k, 4) = '' Then arr1(k, 4) = 0arr1(k, 9) = '借'If arr1(k, 10) = '' Then arr1(k, 10) = 0arr1(k + 1, 2) = '贷方合计'arr1(k + 1, 3) = '贷'If arr1(k + 1, 4) = '' Then arr1(k + 1, 4) = 0arr1(k + 1, 9) = '贷'If arr1(k + 1, 10) = '' Then arr1(k + 1, 10) = 0h = Sheets(5).Range('b65536').End(xlUp).RowSheets(5).Range('a5:j' & h).ClearContentsSheets(5).Range('a5').Resize(UBound(arr1), 10) = arr1h = Sheets(5).Range('b65536').End(xlUp).RowSheets(5).Range('a5:j' & h).Borders.LineStyle = xlContinuousSheets(5).Range('a5:j' & h).ShrinkToFit = TrueApplication.ScreenUpdating = TrueEnd Sub