VBA学习笔记72-2: 综合实例-出入库功能模块

夏西蓝

不用关注我哈，不会再更VBA的内容了

学习资源：《Excel VBA从入门到进阶》第74集 by兰色幻想

一、商品代码的下拉列表

商品代码来源于数据库Cangku的“代码表”，下拉列表可显示所有商品代码。

代码讲解：

（1）打开、关闭数据库及提取数据库记录（类模块）

为方便重复调用和让代码简洁，把打开、关闭数据库连接，和提取数据库记录的代码写在类模块里。

Function 筛选结果(sq As String)
Dim conn As New Connection
Dim rst As New Recordset
conn.Open "provider=Microsoft.jet.OLEDB.4.0;data source=" & ThisWorkbook.Path & "/Database/CangKu.mdb"
Set rst = conn.Execute(sq)
筛选结果 = rst.GetRows   '提取数据库中所有的记录
conn.Close   '关闭数据库
Set conn = Nothing  '释放对象
End Function

（2）把从数据库提取到的记录放到数组和字典中，以便生成下拉列表。

Sub 代码表存为数组()
Dim data As New Data查询
Dim sql As String
Dim arr, y
sql = "Select * from 代码表"
arr = data.筛选结果(sql)   '把从数据库中提取的数据放到数组中
For y = 1 To UBound(arr, 2)
    D(arr(0, y)) = arr(1, y) & "-" & arr(2, y)   '商品代码作为字典key，商品名称连接入库单价作为字典item
Next y
End Sub

（3）生成下拉列表

在Excel中设置下拉列表是通过数据验证设置的，在VBA中也有这个对象。

.Validation. Add (Type,AlertStyle,Operator,Formula1,Formula2)

除Type是必填，其他都是选填。详细介绍看帮助文件，就不在这详细说了。

xlValidateCustom，使用公式验证数据
xlValidateInputOnly，任何值（不能为空）
xlValidateList，序列
xlValidateWholeNumber，整数值
xlValidateDate，日期
xlValidateDecimal，小数值
xlValidateTextLength，文本长度
xlValidateTime，时间

Sub 生成下拉() Dim sr As String Call 代码表存为数组 sr = Join(D.Keys, ",") '把字典的key（商品代码）用逗号连接在一起，待会赋值到数据验证里 With Range("C8:C17").Validation '设置C8:C17单元格的数据验证 .Delete '先把旧的数据验证删了（考虑数据库数值可能有更新） .Add Type:=xlValidateList, Formula1:=sr '添加数据验证，验证条件是序列，来源是商品代码字符串sr End With End Sub

2. 如果商品代码（数据库）有更新，点击入库单下方的“更新下拉”按钮，就能更新下拉列表。

“更新下拉”按钮链接“生成下拉“宏，点击就会重新生成下拉列表。

二、录入

1 .在入库单录入信息，在下拉列表中选择好商品代码填入后，表格会自动带入商品名称和入库单价。填写入库数量后，表格会自动计算填入入库金额。而删除商品代码，后面四列的信息也会被一并删除。

代码详解：

使用工作表事件，一旦指定单元格区域（商品代码）数值发生变化，也对应变化。

如果输入了商品代码，就自动带入商品名称和入库单价；如果是删除了商品代码，也删除后面的商品名称、入库数量和入库单价。

Private Sub Worksheet_Change(ByVal Target As Range) If Application.Intersect(Range("C8:C17"), Target) Is Nothing Or Target.Count > 1 Then Exit Sub '判断发生改变的单元格区域是否在C8:C17之外，且其区域不止一个单元格,退出程序 '数据验证只能在单个单元格选，此处不考虑复制数值的情况。 If D.Count = 0 Then Call 代码表存为数组 '如果字典的数值为空，执行入库模块中的“代码表存为数组”代码生成字典 If Target.Value = "" Then '如果发生改变的单元格值为空 Target.Offset(0, 1) = "" Target.Offset(0, 2) = "" Target.Offset(0, 3) = "" '删除商品名称，入库数量、入库单价 Target.Offset(0, 1) = Split(D(CStr(Target.Value)), "-")(0) Target.Offset(0, 3) = Split(D(CStr(Target.Value)), "-")(1) Target.Offset(0, 2) = "" '自动填入商品名称和入库单价，清空入库数量以便重新填 '根据商品名称查到字典对应的值，但当时是用了"-"连接，用Split拆分,0和1表示拆分的第一个和第二个值 'CStr函数可把表达式转换为字符串(String)类型 End If End Sub

入库金额直接在表格输入公式，不写代码了。

2. 填入填写完毕后，点击“录入”按钮，把数据录入到数据库RuKu表中。但如果入库单已存在则不可直接录入，应该点击“修改”，所以要先进行判断。

这里用的是Access数据库Cangku的RuKu表。

Access数据库Cangku的RuKu表

① 打开和关闭数据库（类模块）

Sub 执行sql命令(sq As String) Dim conn As New Connection Dim rst As New Recordset conn.Open "provider=Microsoft.jet.OLEDB.4.0;data source=" & ThisWorkbook.Path & "/Database/CangKu.mdb" conn.Execute (sq) conn.Close '关闭数据库 Set conn = Nothing '释放对象 End Sub

② 判断入库单号码是否存在

写个函数来判断，并放到类模块中，因为在查询功能也需要用到，这样可多次调用。

Function 是否存在(ku As String, zd As String, zh As String) 'ku指定查找的表,zd是判断的字段,zh 是值 Dim conn As New Connection Dim rst As New Recordset Dim sql As String, arr conn.Open "provider=Microsoft.jet.OLEDB.4.0;data source=" & ThisWorkbook.Path & "/Database/CangKu.mdb" sql = "Select * from " & ku & " where " & zd & "='" & zh & "'" '判断指定字符串是否在数据库中存在 rst.Open sql, conn, 1, 1 '打开记录集 If rst.RecordCount = 0 Then '如果记录集没有数据，则不存在，反之存在。是否存在 = False 是否存在 = True End If conn.Close Set rst = Nothing Set conn = Nothing End Function

③ 录入按钮的宏

用刚刚编写的“是否存在”函数，判断入库单号码是否存在，如存在，弹窗显示“已存在该入库单号码，请不要重复录入”并退出程序。

如不存在，则把

Sub 入库录入() Dim arr, arr1, x As Integer, mydate As Date, hm As String, sr As String, sql As String Dim mydata As New Data查询 mydate = [E6] '取得入库单日期 hm = [G6] '取得入库单号码 If mydata.是否存在("Ruku", "入库单号码", hm) = True Then '判断入库单号码是否存在 MsgBox "已存在该入库单号码，请不要重复录入" Exit Sub arr = Range("C8:G" & Range("F18").End(xlUp).Row) '把入库单C8:G17中不为空的数值放在数组arr，方便调用 For x = 1 To UBound(arr) sr = "#" & mydate & "#" & ",'" & hm & "','" & arr(x, 1) & "','" & arr(x, 2) & "'," sr = sr & arr(x, 3) & "," & arr(x, 4) & "," & arr(x, 5) 'SQL语句中日期用#号括起来，文本型字符串用单引号括起来。 sql = "Insert into ruku (入库日期, 入库单号码, 商品代码,商品名称,入库数量,入库单价,入库金额) VALUES(" & sr & ")" mydata.执行sql命令 (sql) '对应在数据库输入数据 Next x MsgBox "成功录入数据库" End If End Sub

三、查询

对输入的入库单号码进行查询，看是否存在。如存在，显示查询的入库单内容。

如不存在，弹窗显示“已存在该入库单号码，请不要重复录入”并退出程序

Sub 入库查询() Dim mydata As New Data查询 Dim sql As String, arr, x, y If mydata.是否存在("Ruku", "入库单号码", [g6]) = False Then '判断输入的入库单号码是否不存在 MsgBox "该入库单号码不存在" Exit Sub Application.EnableEvents = False '禁止触发工作表改变事件 Range("c8:f17") = "" '清空入库单内容 sql = "select * from RuKu where 入库单号码='" & [g6] & "'" '从数据库中查找入库单号码对应的记录 arr = mydata.筛选结果(sql) '查询到的记录放在数组中 [e6] = arr(0, 0) '输入入库日期 For y = 0 To UBound(arr, 2) '循环输入其他数据 For x = 2 To UBound(arr) - 1 Cells(y + 8, x + 1) = arr(x, y) Next x Next y Application.EnableEvents = True '恢复可触发工作表改变事件 End If End Sub

四、删除

和查询的代码类似，不过在数据库查询到后不输入到入库单工作表，而且到数据库中删除记录。

Sub 入库删除() Dim data As New Data查询, sql As String If data.是否存在("Ruku", "入库单号码", [g6]) = False Then '在数据库中查询入库单数据 MsgBox "此入库单号码不存在" Exit Sub sql = "Delete from Ruku where 入库单号码='" & [g6] & "'" '在数据库中删除入库单数据 data.执行sql命令 sql MsgBox "已删除入库单号码为" & [g6] & "的记录"