迷你记账系统制作：[8]凭证修改打印保存

本讲将详细介绍凭证检索修改及打印保存功能的实现。

工具/原料

Excel2003

VBA

打印保存功能实现

1、在Sheet2（录入凭证）代码窗口粘贴如下代码。Private Sub CommandButton1_Click() '凭证打印并保存Dim h As Byte, arr, i As Byte, xcount As Byte, ycount As Byteh = Sheets(2).Range("c10").End(xlUp).Row + 1arr = Sheets(2).Range("c4:e10")For i = 1 To UBound(arr)If arr(i, 1) = "现金" And arr(i, 3) <> 0 And Sheets(2).Range("e1").Value <> "现金" Then '存在现金贷方科目则凭证类型必定为现金 MsgBox "该凭证类型应该为现金凭证（付方在现金）！", vbInformation, "凭证类型选择错误" Exit SubElseIf InStr(1, arr(i, 1), "银行存款") And arr(i, 3) <> 0 And Sheets(2).Range("e1").Value <> "银行" Then '存在银行存款贷方科目则凭证类型必定为银行 MsgBox "该凭证类型应该为银行凭证（付方在银行）！", vbInformation, "凭证类型选择错误" Exit SubEnd IfIf InStr(1, arr(i, 1), "银行存款") <> 0 Then ycount = ycount + 1 '统计银行存款科目个数Next ixcount = Application.WorksheetFunction.CountIf(Sheets(2).[c4:c10], "现金") '统计现金科目个数If Sheets(2).Range("e1").Value = "现金" ThenIf xcount = 0 Then MsgBox "现金凭证必需含有现金科目", vbInformation, "错误" Exit SubEnd IfElseIf Sheets(2).Range("e1").Value = "银行" ThenIf ycount = 0 Then MsgBox "银行凭证必需含有银行存款科目", vbInformation, "错误"Exit SubEnd IfElseIf Sheets(2).Range("e1").Value = "转账" ThenIf xcount <> 0 Or ycount <> 0 Then MsgBox "转账凭证不可含有现金或者银行存款科目", vbInformation, "错误" Exit SubEnd IfEnd IfIf h <> 4 ThenIf h > 4 Then Range("a" & h & ":e10").ClearContents Range("G" & h & ":G10").ClearContentsEnd IfIf Range("d11").Value = Range("e11").Value Then Call pdcrpzzbElse MsgBox "借贷不平！请检查修改！", vbExclamation, "借贷不平！警告！"End IfElseMsgBox "数据未输入！", vbInformation, "错误"End IfEnd Sub

2、在自定义函数过程模块中，粘贴如下代码：Sub crpzzb(Optional str As String = "", Optional czksh As Integer = 1)Dim zh As Integer, h As Integer, i As Integer, j As Integerh = Sheets(2).Range("c10").End(xlUp).RowIf h = 1 Then h = 10If czksh = 1 Thenzh = Sheets(4).Range("a65536").End(xlUp).Row + 1Elsezh = czkshEnd IfFor i = 4 To hIf str = "" ThenSheets(4).Cells(zh, 1) = Sheets(2).DTPicker1.ValueElseSheets(4).Cells(zh, 1) = strEnd IfSheets(4).Cells(zh, 2) = Sheets(2).Range("e2").ValueSheets(4).Cells(zh, 3) = Sheets(2).Range("e1").ValueSheets(4).Cells(zh, 10) = Sheets(2).Range("c13").ValueSheets(4).Cells(zh, 11) = Sheets(2).Range("d13").ValueSheets(4).Cells(zh, 12) = Sheets(2).Range("b13").ValueSheets(4).Cells(zh, 15) = Sheets(2).Range("f7").ValueSheets(4).Cells(zh, 13) = Sheets(2).Range("a13").ValueSheets(4).Cells(zh, 14) = Sheets(2).Range("e13").ValueFor j = 1 To 5 Select Case j Case 1 Sheets(4).Cells(zh, 4) = Sheets(2).Cells(i, j) Case 2 If InStr(1, Sheets(2).Cells(i, j + 1), "-", 0) Then Sheets(4).Cells(zh, 6) = Split(Sheets(2).Cells(i, j + 1), "-", 2)(0) Sheets(4).Cells(zh, 7) = Split(Sheets(2).Cells(i, j + 1), "-", 2)(1) Else Sheets(4).Cells(zh, 6) = Sheets(2).Cells(i, j + 1) End If Case 3 Sheets(4).Cells(zh, 8) = Sheets(2).Cells(i, j + 1) Case 4 Sheets(4).Cells(zh, 9) = Sheets(2).Cells(i, j + 1) Case 5 Sheets(4).Cells(zh, 5) = Sheets(2).Cells(i, j + 2) End SelectNextzh = zh + 1NextSheets(3).Range("d4") = Sheets(2).DTPicker1.ValueThisWorkbook.SaveSheets(3).PrintPreviewCall pzhmtcSheets(2).Range("a4:e10").ClearContentsSheets(2).Range("g4:g10").ClearContentsEnd SubSub pdcrpzzb()Dim str As String, str1 As String, str2 As String, str3 As StringDim flagcz As Boolean, czh As Integer, czcs As Byte 'flagcz用来标记该张凭证是否已存在，czh用来记忆存在开始的行号,czcs用来标记存在的行数flagcz = Falsestr = Year(Sheets(2).DTPicker1.Value) & "/" & Month(Sheets(2).DTPicker1.Value) & Sheets(2).Range("e2") & Sheets(2).Range("e1")h = Sheets(4).Range("a65536").End(xlUp).Rowarr1 = Sheets(4).Range("a2:c" & h)If h > 1 ThenFor i = 1 To UBound(arr1) '取存在开始行号czh、存在的行数czcs的值 For j = 1 To 3 If j = 1 Then str1 = Year(arr1(i, j)) & "/" & Month(arr1(i, j)) Else str1 = str1 & arr1(i, j) End If Next j If str = str1 Then If flagcz = False Then czh = i + 1 flagcz = True czcs = czcs + 1 End If str1 = ""Nextpzhh = Sheets(2).Range("c10").End(xlUp).RowIf pzhh = 1 Then '取凭证行数pzhs的值pzhs = 7Elsepzhs = pzhh - 3End If' If czh <> 0 Then str2 = Sheets(4).Cells(czh, 1)End IfIf flagcz Thenstr3 = Year(Sheets(2).DTPicker1.Value) & "年" & Month(Sheets(2).DTPicker1.Value) & "月" & Sheets(2).Range("e1") & Sheets(2).Range("e2")q = MsgBox("请谨慎操作！！！！" & Chr(10) & Chr(32) & Chr(32) & Chr(32) & Chr(32) & Chr(32) & Chr(32) & _ "继续操作将会覆盖原有凭证，是否确认修改？", vbExclamation + vbYesNo, str3 & "号凭证已经存在！警告！")If q = 6 ThenIf pzhs > czcs ThenSheets(4).Rows(czh + czcs & ":" & czh + pzhs - 1).Insert Shift:=xlDownSheets(4).Rows(czh & ":" & czh + pzhs - 1).ClearContentsElseIf pzhs < czcs ThenSheets(4).Rows(czh + pzhs & ":" & czh + czcs - 1).DeleteSheets(4).Rows(czh & ":" & czh + pzhs - 1).ClearContentsElseIf pzhs = czcs ThenSheets(4).Rows(czh & ":" & czh + czcs - 1).ClearContentsEnd IfCall crpzzb(str2, czh)ElseExit SubEnd IfElseCall crpzzbEnd IfEnd Sub

修改检索功能实现

1、新建一个用户窗体，名称改为：修改选择检索，caption属性设为：修改选择-检索条件，其他属性如图示。

2、利用框架控件在修改选择检索窗体上拖拉出一个框架。名称设为：Frame1，caption属性改为：条件选项，其他属性如图。

3、在框架上面利用标签控件分别拖拉出4个标签，caption属性分别改为：“凭证类型：”、“凭证日期：”、“凭证号码：”、“月”，其他属性分别如下图。

4、利用复合框控件，在框架上拖拉出一个复合框，名称改为：pzlx，Text属性设为：现金，Value属性也设为：现金。其他属性如图示。

5、利用文字框控件拖拉出2个文字框，名称分别设为：yf、pzhm，其他属性分别如下图所示。

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

7、此修改选择检索窗体界面最终效果如图示。

8、在sheet2（录入凭证）代码窗口粘贴如下代码：Private Sub CommandButton2_Click() '凭证修改修改选择检索.ShowEnd Sub

9、在修改选择检索窗体右键查看代码，在代码窗口粘贴如下代码：Private Sub CommandButton1_Click()Dim str As String, str1 As String, arr, i As Integer, j As Byte, flagcz As Booleanj = 4flagcz = Falsestr = Year(Sheets(2).DTPicker1.Value) & "/" & yf.Value & pzhm.Value & pzlx.Valuearr = Sheets(4).Range("a2:o" & Sheets(4).Range("b65536").End(xlUp).Row)For i = 1 To UBound(arr)str1 = Year(arr(i, 1)) & "/" & Month(arr(i, 1)) & arr(i, 2) & arr(i, 3)If str = str1 Then If j = 4 Then Sheets(2).Range("a4:e10").ClearContents Sheets(2).Range("g4:g10").ClearContents flagcz = True Sheets(2).DTPicker1.Value = arr(i, 1) Sheets(2).Range("e1") = arr(i, 3) Sheets(2).Range("e2") = arr(i, 2) Sheets(2).Range("a13") = arr(i, 13) Sheets(2).Range("b13") = arr(i, 12) Sheets(2).Range("c13") = arr(i, 10) Sheets(2).Range("d13") = arr(i, 11) Sheets(2).Range("e13") = arr(i, 14) Sheets(2).Range("f7") = arr(i, 15) End If Sheets(2).Range("a" & j) = arr(i, 4) If arr(i, 7) = "" Then Sheets(2).Range("c" & j) = arr(i, 6) Else Sheets(2).Range("c" & j) = arr(i, 6) & "-" & arr(i, 7) End If Sheets(2).Range("d" & j) = arr(i, 8) Sheets(2).Range("e" & j) = arr(i, 9) Sheets(2).Range("g" & j) = arr(i, 5) j = j + 1End IfNextIf flagcz ThenUnload MeElseMsgBox "未找到此张凭证", vbOKOnly, "凭证未找到"End IfEnd SubPrivate Sub CommandButton2_Click()Unload MeEnd SubPrivate Sub ScrollBar1_Change()yf.Text = ScrollBar1.ValueEnd SubPrivate Sub UserForm_Initialize()pzlx.List = Array("现金", "银行", "转账")End Sub