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

1、在Sheet2（录入凭证）代码窗口粘贴如下代码。

Private Sub CommandButton1_Click() '凭证打印并保存

Dim h As Byte, arr, i As Byte, xcount As Byte, ycount As Byte

h = Sheets(2).Range("c10").End(xlUp).Row + 1

arr = 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 Sub

 ElseIf InStr(1, arr(i, 1), "银行存款") And arr(i, 3) <> 0 And Sheets(2).Range("e1").Value <> "银行" Then '存在银行存款贷方科目则凭证类型必定为银行

  MsgBox "该凭证类型应该为银行凭证（付方在银行）！", vbInformation, "凭证类型选择错误"

  Exit Sub

 End If

 If InStr(1, arr(i, 1), "银行存款") <> 0 Then ycount = ycount + 1 '统计银行存款科目个数

Next i

xcount = Application.WorksheetFunction.CountIf(Sheets(2).[c4:c10], "现金") '统计现金科目个数

If Sheets(2).Range("e1").Value = "现金" Then

 If xcount = 0 Then

  MsgBox "现金凭证必需含有现金科目", vbInformation, "错误"

  Exit Sub

 End If

ElseIf Sheets(2).Range("e1").Value = "银行" Then

 If ycount = 0 Then

  MsgBox "银行凭证必需含有银行存款科目", vbInformation, "错误"

  Exit Sub

 End If

ElseIf Sheets(2).Range("e1").Value = "转账" Then

 If xcount <> 0 Or ycount <> 0 Then

  MsgBox "转账凭证不可含有现金或者银行存款科目", vbInformation, "错误"

  Exit Sub

 End If

End If

If h <> 4 Then

 If h > 4 Then

  Range("a" & h & ":e10").ClearContents

  Range("G" & h & ":G10").ClearContents

 End If

 If Range("d11").Value = Range("e11").Value Then

  Call pdcrpzzb

 Else

  MsgBox "借贷不平！请检查修改！", vbExclamation, "借贷不平！警告！"

 End If

Else

 MsgBox "数据未输入！", vbInformation, "错误"

End If

End 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 Integer

h = Sheets(2).Range("c10").End(xlUp).Row

If h = 1 Then h = 10

If czksh = 1 Then

zh = Sheets(4).Range("a65536").End(xlUp).Row + 1

Else

zh = czksh

End If

For i = 4 To h

 If str = "" Then

 Sheets(4).Cells(zh, 1) = Sheets(2).DTPicker1.Value

 Else

 Sheets(4).Cells(zh, 1) = str

 End If

 Sheets(4).Cells(zh, 2) = Sheets(2).Range("e2").Value

 Sheets(4).Cells(zh, 3) = Sheets(2).Range("e1").Value

 Sheets(4).Cells(zh, 10) = Sheets(2).Range("c13").Value

 Sheets(4).Cells(zh, 11) = Sheets(2).Range("d13").Value

 Sheets(4).Cells(zh, 12) = Sheets(2).Range("b13").Value

 Sheets(4).Cells(zh, 15) = Sheets(2).Range("f7").Value

 Sheets(4).Cells(zh, 13) = Sheets(2).Range("a13").Value

 Sheets(4).Cells(zh, 14) = Sheets(2).Range("e13").Value

 For 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 Select

 Next

 zh = zh + 1

Next

Sheets(3).Range("d4") = Sheets(2).DTPicker1.Value

ThisWorkbook.Save

Sheets(3).PrintPreview

Call pzhmtc

Sheets(2).Range("a4:e10").ClearContents

Sheets(2).Range("g4:g10").ClearContents

End Sub

Sub pdcrpzzb()

Dim str As String, str1 As String, str2 As String, str3 As String

Dim flagcz As Boolean, czh As Integer, czcs As Byte 'flagcz用来标记该张凭证是否已存在，czh用来记忆存在开始的行号,czcs用来标记存在的行数

flagcz = False

str = 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).Row

arr1 = Sheets(4).Range("a2:c" & h)

If h > 1 Then

 For 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 = ""

 Next

 pzhh = Sheets(2).Range("c10").End(xlUp).Row

 If pzhh = 1 Then '取凭证行数pzhs的值

 pzhs = 7

 Else

 pzhs = pzhh - 3

 End If

' If czh <> 0 Then str2 = Sheets(4).Cells(czh, 1)

End If

If flagcz Then

str3 = 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 Then

If pzhs > czcs Then

Sheets(4).Rows(czh + czcs & ":" & czh + pzhs - 1).Insert Shift:=xlDown

Sheets(4).Rows(czh & ":" & czh + pzhs - 1).ClearContents

ElseIf pzhs < czcs Then

Sheets(4).Rows(czh + pzhs & ":" & czh + czcs - 1).Delete

Sheets(4).Rows(czh & ":" & czh + pzhs - 1).ClearContents

ElseIf pzhs = czcs Then

Sheets(4).Rows(czh & ":" & czh + czcs - 1).ClearContents

End If

Call crpzzb(str2, czh)

Else

Exit Sub

End If

Else

Call crpzzb

End If

End 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() '凭证修改

修改选择检索.Show

End Sub

9、在修改选择检索窗体右键查看代码，在代码窗口粘贴如下代码：

Private Sub CommandButton1_Click()

Dim str As String, str1 As String, arr, i As Integer, j As Byte, flagcz As Boolean

j = 4

flagcz = False

str = Year(Sheets(2).DTPicker1.Value) & "/" & yf.Value & pzhm.Value & pzlx.Value

arr = 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 + 1

 End If

Next

If flagcz Then

 Unload Me

Else

 MsgBox "未找到此张凭证", vbOKOnly, "凭证未找到"

End If

End Sub

Private Sub CommandButton2_Click()

Unload Me

End Sub

Private Sub ScrollBar1_Change()

yf.Text = ScrollBar1.Value

End Sub

Private Sub UserForm_Initialize()

pzlx.List = Array("现金", "银行", "转账")

End Sub