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

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

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

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

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

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

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

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