在Excel中用vba编写的进销存管理系统

一、进销管理系统简介

以Access作为数据库，在Excel中用vba编写的进销存管理系统。概系统有以下七大功能：

1、“入库单”操作界面，可以实现入库单的录入、查询、删除和修改功能。

2、“出库单”操作界面，可以实现出库单的录入、查询、删除和修改功能。

3、“入库明细查询”操作界面，可以根据入库日期（年或年月或年月日）、商品名称、或入库单号，查询入库明细。

4、“出库明细查询”操作界面，可以根据出库日期（年或年月或年月日）、商品名称、或出库单号，查询出库明细。

5、“入库汇总查询”操作界面，可以根据汇总区间（开始日期~结束日期），按商品代码进行入库信息的分组汇总查询。

6、“出库汇总查询”操作界面，可以根据汇总区间（开始日期~结束日期），按商品代码进行出库信息的分组汇总查询。

7、“进销存报表“操作界面，可以根据汇总区间（开始日期~结束日期），对所有商品或某一指定商品生成进销存报表。

1、“入库单”操作界面

2、“出库单”操作界面

3、“入库明细查询”操作界面

4、“出库明细查询”操作界面

5、“入库汇总查询”操作界面

6、“出库汇总查询”操作界面

7、“进销存报表“操作界面

三、程序代码

(一)出入库单

1、入库单事件程序

Private Sub Worksheet_Activate()

Call 更新商品代码

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rg As Range

Dim spdm As String

Dim r As Integer

Set rg = Range("C4:C13")

If Application.Intersect(rg, Target) Is Nothing Or Target.Count > 1 Then

    Exit Sub

Else

    If d.Count < 1 Then

        Call 更新商品代码

    End If

End If

spdm = Target.Value

If d.Exists(spdm) Then

Else

    Application.EnableEvents = False '避免改变事件被无限触发

    Target = ""

    spdm = Target.Value

    Application.EnableEvents = True

End If   

If spdm = "" Then

    Target.Offset(0, 1) = ""

    Target.Offset(0, 2) = ""

    Target.Offset(0, 3) = ""

    Target.Offset(0, 4) = ""

Else

    r = Target.Row

    Target.Offset(0, 1) = VBA.Split(d(spdm), "-")(0)

    Target.Offset(0, 2) = ""

    Target.Offset(0, 3) = VBA.Split(d(spdm), "-")(3)

    Target.Offset(0, 4) = "=E" & r & "*F" & r

End If

End Sub

2、出库单事件程序

Private Sub Worksheet_Activate()

Call 更新商品代码

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rg As Range

Dim spdm As String

Dim r As Integer

Set rg = Range("C4:c13")

If Application.Intersect(rg, Target) Is Nothing Or Target.Count > 1 Then

    Exit Sub

Else

    If d.Count < 1 Then

        Call 更新商品代码

    End If

End If

spdm = Target.Value

If d.Exists(spdm) Then

Else

    Application.EnableEvents = False '避免改变事件被无限触发

    Target = ""

    spdm = Target.Value

    Application.EnableEvents = True

End If   

If spdm = "" Then

    Target.Offset(0, 1) = ""

    Target.Offset(0, 2) = ""

    Target.Offset(0, 3) = ""

    Target.Offset(0, 4) = ""

Else

    r = Target.Row

    Target.Offset(0, 1) = VBA.Split(d(spdm), "-")(0)

    Target.Offset(0, 2) = ""

    Target.Offset(0, 3) = VBA.Split(d(spdm), "-")(3)

    Target.Offset(0, 4) = "=E" & r & "*F" & r

End If

End Sub

3、出入库模块程序

Public d As New Dictionary

'******************************入库单Start*****************************

Sub 刷新入库单()

Call 设置表单格式

If VBA.IsDate(Range("D2")) And Range("D2") > 0 Then

Else

    Call 获取当前日期

End If

Call 获取当前日期可用单号(1)

Call 清空单据明细

Call 更新商品代码

End Sub

Sub 更新入库单商品代码()

Call 更新商品代码

End Sub

Sub 录入入库单()

Dim m

If 单据信息是否完整(1) Then

Else

    MsgBox "入库单信息不完整或格式有错误"

    Exit Sub

End If

If 检查单号是否已存在(1) Then

    MsgBox ("入库单号已存在")

    Exit Sub

End If

m = MsgBox(prompt:="确定要录入此入库单信息吗？", Buttons:=vbQuestion + vbYesNo, Title:="入库单录入")

If m = vbYes Then

    Call 明细录入(1)

    MsgBox "入库单" & Range("F2") & "录入完成"

Else

    MsgBox "录入已取消"

End If

End Sub

Sub 查询入库单()

Dim dh As String

Dim mysql As String

Dim arr, t

Range("D2,C4:G13") = ""

If 检查单号是否已存在(1) Then

Else

    MsgBox "入库单号" & Range("F2") & "不存在"

    Exit Sub

End If

dh = Range("F2")

mysql = "select first(入库日期) as 入库日期 from 入库单 where 入库单号='" & dh & "'"

arr = 执行sql语句筛选(mysql)

Range("D2") = arr(0, 0)

mysql = "select 商品代码,商品名称,入库数量,入库单价,入库金额 from 入库单 where 入库单号='" & dh & "'"

arr = 执行sql语句筛选(mysql)

arr = Application.WorksheetFunction.Transpose(arr)

If 判断数组维数(arr) = 1 Then

   t = 1

Else

   t = UBound(arr, 1)

End If

Range("C4").Resize(t, 5) = arr

For r = 1 To t

    Cells(3 + r, "G") = "=E" & (3 + r) & "*F" & (3 + r)

Next r

End Sub

Sub 删除入库单()

Dim m

If 检查单号是否已存在(1) Then   

Else

    MsgBox "此入库单号" & Range("F2") & "不存在"

    Exit Sub

End If

m = MsgBox(prompt:="确定要删除此入库单吗？", Buttons:=vbQuestion + vbYesNo, Title:="入库单删除")

If m = vbYes Then

    Call 明细删除(1)

    MsgBox "入库单" & Range("F2") & "删除完成"

    Range("C4:G13") = ""

Else

    MsgBox "入库单删除已取消"

End If

End Sub

Sub 修改入库单()

Dim m

If 单据信息是否完整(1) Then

Else

    MsgBox "入库单信息不完整或格式有错误"

    Exit Sub

End If

If 检查单号是否已存在(1) Then

Else

    MsgBox ("入库单号不存在")

    Exit Sub

End If

m = MsgBox(prompt:="确定要修改此入库单信息吗？", Buttons:=vbQuestion + vbYesNo, Title:="入库单修改")

If m = vbYes Then

    Call 明细删除(1)

    Call 明细录入(1)

    MsgBox "入库单" & Range("F2") & "修改完成"

Else

    MsgBox "修改已取消"

End If

End Sub

'******************************入库单End*****************************

'******************************出库单Start*****************************

Sub 刷新出库单()

Call 设置表单格式

If VBA.IsDate(Range("D2")) And Range("D2") > 0 Then

Else

    Call 获取当前日期

End If

Call 获取当前日期可用单号(2)

Call 清空单据明细

End Sub

Sub 更新出库单商品代码()

Call 更新商品代码

End Sub

Sub 录入出库单()

Dim m

If 单据信息是否完整(2) Then

Else

    MsgBox "出库单信息不完整或格式有错误"

    Exit Sub

End If

If 检查单号是否已存在(2) Then

    MsgBox ("出库单号已存在")

    Exit Sub

End If

m = MsgBox(prompt:="确定要录入此出库单信息吗？", Buttons:=vbQuestion + vbYesNo, Title:="出库单录入")

If m = vbYes Then

    Call 明细录入(2)

    MsgBox "出库单" & Range("F2") & "录入完成"

Else

    MsgBox "录入已取消"

End If

End Sub

Sub 查询出库单()

Dim dh As String

Dim mysql As String

Dim arr, t

Range("D2,C4:G13") = ""

If 检查单号是否已存在(2) Then

Else

    MsgBox "出库单号" & Range("F2") & "不存在"

    Exit Sub

End If

dh = Range("F2")

mysql = "select first(出库日期) as 出库日期 from 出库单 where 出库单号='" & dh & "'"

arr = 执行sql语句筛选(mysql)

Range("D2") = arr(0, 0)

mysql = "select 商品代码,商品名称,出库数量,销售单价,销售金额 from 出库单 where 出库单号='" & dh & "'"

arr = 执行sql语句筛选(mysql)

arr = Application.WorksheetFunction.Transpose(arr)

If 判断数组维数(arr) = 1 Then

   t = 1

Else

   t = UBound(arr, 1)

End If

Range("C4").Resize(t, 5) = arr

For r = 1 To t

    Cells(3 + r, "G") = "=E" & (3 + r) & "*F" & (3 + r)

Next r

End Sub

Sub 删除出库单()

Dim m

If 检查单号是否已存在(2) Then  

Else

    MsgBox "此出库单号" & Range("F2") & "不存在"

    Exit Sub

End If

m = MsgBox(prompt:="确定要删除此出库单吗？", Buttons:=vbQuestion + vbYesNo, Title:="出库单删除")

If m = vbYes Then

    Call 明细删除(2)

    MsgBox "出库单" & Range("F2") & "删除完成"

    Range("C4:G13") = ""

Else

    MsgBox "出库单删除已取消"

End If

End Sub

Sub 修改出库单()

Dim m

If 单据信息是否完整(2) Then

Else

    MsgBox "出库单信息不完整或格式有错误"

    Exit Sub

End If

If 检查单号是否已存在(2) Then

Else

    MsgBox ("出库单号不存在")

    Exit Sub

End If

m = MsgBox(prompt:="确定要修改此出库单信息吗？", Buttons:=vbQuestion + vbYesNo, Title:="出库单修改")

If m = vbYes Then

    Call 明细删除(2)

    Call 明细录入(2)

    MsgBox "出库单" & Range("F2") & "修改完成"

Else

    MsgBox "修改已取消"

End If

End Sub

'******************************出库单End*******************************

'******************************可调用函数Start*************************

Sub 设置表单格式()

Range("D2").NumberFormatLocal = "yyyy-mm-dd"

Range("F4:F13,G4:G14").NumberFormatLocal = "￥0.00"

Range("E14") = "=sum(E4:E13)"

Range("G14") = "=sum(G4:G13)"

End Sub

Sub 获取当前日期()

'获取当前日期

Range("D2") = Date

End Sub

Sub 获取当前日期可用单号(Optional p As Integer = 1) 'p=1为入库单，p=2为出库单

Dim ds As String

Dim dh As String

Dim bh As String

Dim tj As String

Dim mysql As String

Dim bz As String

Dim arr

If p = 1 Then

    ds = "入库单"

    dh = "入库单号"

    tj = "入库日期"

    bz = "R"

ElseIf p = 2 Then

    ds = "出库单"

    dh = "出库单号"

    tj = "出库日期"

    bz = "C"

End If

mysql = "select max(right(" & dh & ",3)) from " & ds & " where " & tj & "=#" & Range("D2") & "#"

'由于select中用到了max求最大，所以即使没有找到，也会显示有一个空记录

arr = 执行sql语句筛选(mysql)

If VBA.IsNull(arr(0, 0)) Then

    bh = 0

Else

    bh = arr(0, 0)

End If

Range("F2") = bz & Format(Range("D2"), "yyyymmdd") & Format(bh + 1, "000")

End Sub

Function 执行sql语句筛选(sql As String) As Variant '将筛选结果返回给数组

Dim conn As Object

Dim rst As Object

Dim mysql As String

Set conn = VBA.CreateObject("adodb.connection")

mysql = "provider=microsoft.ace.oledb.12.0;data source=D:\仓库数据.accdb"

conn.Open mysql

Set rst = VBA.CreateObject("adodb.recordset")

mysql = sql

rst.Open mysql, conn, 3, 1

If rst.RecordCount = 0 Then

    执行sql语句筛选 = Null

Else

    执行sql语句筛选 = rst.getrows()

End If

rst.Close

conn.Close

Set rst = Nothing

Set conn = Nothing

End Function

Sub 清空单据明细()

Range("C4:G13") = ""

End Sub

Sub 更新商品代码()

Dim mysql As String

Dim arr, i As Integer

mysql = "select * from 代码表"

arr = 执行sql语句筛选(mysql)

If IsNull(arr) Then

    MsgBox "数据库中'代码表'为空"

    Exit Sub

Else

    arr = Application.WorksheetFunction.Transpose(arr)

End If

For i = 1 To UBound(arr, 1)

    d(arr(i, 1)) = VBA.Join(Array(arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5)), "-")

Next i

Range("C4:C13").Validation.Delete

Range("C4:C13").Validation.Add Type:=xlValidateList, Formula1:=VBA.Join(d.Keys, ",")

End Sub

Function 单据信息是否完整(Optional p As Integer = 1) As Boolean 'p=1为入库单，p=2为出库单

Dim str

Dim r As Integer

'检查入库日期格式是否正确

If Not (IsDate(Range("D2"))) Then

   单据信息是否完整 = False

   Exit Function

End If

'检查入库单号是否为12位

If Not (Len(Range("F2")) = 12) Then

   单据信息是否完整 = False

   Exit Function

End If

'检查入库单号格式是否正确

If p = 1 Then

    str = "R" & Format(Range("D2"), "yyyymmdd")

Else

    str = "C" & Format(Range("D2"), "yyyymmdd")

End If

If Not (Left(Range("F2"), 9) = str) Then

   单据信息是否完整 = False

   Exit Function

End If

str = Right(Range("F2"), 3)

If VBA.IsNumeric(str) And str * 1 > 0 And str * 1 < 1000 Then

Else

   单据信息是否完整 = False

   Exit Function

End If

'检查入库单明细是否完整且不为空

r = Range("C14").End(xlUp).Row

If r = 1 Then

    r = 13

End If

If r < 4 Then

   单据信息是否完整 = False

   Exit Function

End If

r = Application.WorksheetFunction.CountIf(Range("C4:G" & r), "")

If r > 0 Then

   单据信息是否完整 = False

   Exit Function

End If

单据信息是否完整 = True

End Function

Function 检查单号是否已存在(Optional p As Integer = 1) As Boolean

Dim mysql As String

Dim dh As String

Dim arr

dh = Range("F2")

If p = 1 Then

    mysql = "select * from 入库单 where 入库单号='" & dh & "'"

Else

    mysql = "select * from 出库单 where 出库单号='" & dh & "'"

End If

arr = 执行sql语句筛选(mysql)

If IsNull(arr) Then

    检查单号是否已存在 = False

Else

    检查单号是否已存在 = True

End If

End Function

Sub 明细录入(Optional p As Integer = 1)

Dim conn As Object

Dim mysql As String

Dim rst As Object

Dim r As Integer

Dim arr, rq, dh

r = Range("C14").End(xlUp).Row

If r = 1 Then

    r = 13

End If

arr = Range("C4:G" & r)

Set conn = VBA.CreateObject("adodb.connection")

mysql = "provider=microsoft.ace.oledb.12.0;data source=D:\仓库数据.accdb"

conn.Open mysql

Set rst = VBA.CreateObject("adodb.recordset")

If p = 1 Then

    mysql = "select * from 入库单"

    rst.Open mysql, conn, 3, 3

    For r = 1 To UBound(arr, 1)

        rst.addnew Array("入库日期", "入库单号", "商品代码", "商品名称", "入库数量", "入库单价", "入库金额"), _

        Array(Range("D2"), Range("F2"), CStr(arr(r, 1)), arr(r, 2), arr(r, 3), arr(r, 4), arr(r, 5))

    Next r

Else

    mysql = "select * from 出库单"

    rst.Open mysql, conn, 3, 3

    For r = 1 To UBound(arr, 1)

        rst.addnew Array("出库日期", "出库单号", "商品代码", "商品名称", "出库数量", "销售单价", "销售金额"), _

        Array(Range("D2"), Range("F2"), CStr(arr(r, 1)), arr(r, 2), arr(r, 3), arr(r, 4), arr(r, 5))

    Next r

End If

conn.Close

Set rst = Nothing

Set conn = Nothing

End Sub

Sub 明细删除(Optional p As Integer = 1)

Dim conn As Object

Dim mysql As String

Dim rst As Object

Set conn = VBA.CreateObject("adodb.connection")

mysql = "provider=microsoft.ace.oledb.12.0;data source=D:\仓库数据.accdb"

conn.Open mysql

Set rst = VBA.CreateObject("adodb.recordset")

If p = 1 Then

    mysql = "delete * from 入库单 where 入库单号='" & Range("F2") & "'"

Else

    mysql = "delete * from 出库单 where 出库单号='" & Range("F2") & "'"

End If

rst.Open mysql, conn, 3, 3

conn.Close

Set rst = Nothing

Set conn = Nothing

End Sub

Function 判断数组维数(arr) As Integer

Dim i As Integer

If Not (IsArray(arr)) Then

    判断数组维数 = 0 '不是数组

    Exit Function

End If

On Error Resume Next

For i = 1 To 100

    If IsError(UBound(arr, i)) Then

        Exit For

    End If

Next i

On Error GoTo 0

判断数组维数 = i - 1

End Function

'******************************可调用函数End*************************

(二)出入库明细查询

1、入库明细查询事件程序

Private Sub Worksheet_Activate()

Call 更新商品名称

End Sub

2、出库明细查询事件程序

Private Sub Worksheet_Activate()

Call 更新商品名称

End Sub

3、出入库明细查询模块程序

Public dmx As New Dictionary

'******************************入库明细查询Start*****************************

Sub 查询入库明细()

Dim rq, rqstr As String

Dim mc, mcstr As String

Dim dh, dhstr As String

Dim str As String

Dim mysql As String

Dim arr

Call 清空明细查询结果

rq = 查询条件日期

mc = 查询条件商品名称

dh = 查询条件单号

If rq = 0 Then

    rqstr = "1"

    Range("D5,E5") = ""

ElseIf rq = 1 Then

    rqstr = "year(入库日期)='" & Range("C5") & "'"

    Range("E5") = ""

ElseIf rq = 2 Then

    rqstr = "year(入库日期)='" & Range("C5") & "' and month(入库日期)='" & Range("D5") & "'"

ElseIf rq = 3 Then

    rqstr = "year(入库日期)='" & Range("C5") & "' and month(入库日期)='" & Range("D5") & "' and day(入库日期)='" & Range("E5") & "'"

End If

If mc = 0 Then

    mcstr = "1"

Else

    mcstr = "商品代码='" & VBA.Split(Range("F5"), "-")(0) & "'"

End If

If dh = 0 Then

    dhstr = "1"

Else

    dhstr = "入库单号='" & Range("H5") & "'"

End If

 str = "( " & rqstr & " ) and ( " & mcstr & " ) and ( " & dhstr & " )"

 mysql = "select * from 入库单 where " & str & " order by 入库日期 desc"

 arr = 执行sql语句筛选(mysql)

 If IsNull(arr) Then

 Else

    arr = Application.WorksheetFunction.Transpose(arr)   

    If 判断数组维数(arr) = 1 Then

        t = 1

    Else

        t = UBound(arr, 1)

    End If

    Range("C8").Resize(t, 7) = arr

    Range("F" & t + 8) = "合计"

    Range("G" & t + 8) = "=sum(G8:G" & t & ")"

    Range("I" & t + 8) = "=sum(I8:I" & t & ")"

End If

Range("H8:I100").NumberFormatLocal = "￥0.00"

End Sub

'******************************入库明细查询End*****************************

'******************************出库明细查询Start*****************************

Sub 查询出库明细()

Dim rq, rqstr As String

Dim mc, mcstr As String

Dim dh, dhstr As String

Dim str As String

Dim mysql As String

Dim arr

Call 清空明细查询结果

rq = 查询条件日期

mc = 查询条件商品名称

dh = 查询条件单号

If rq = 0 Then

    rqstr = "1"

    Range("D5,E5") = ""

ElseIf rq = 1 Then

    rqstr = "year(出库日期)='" & Range("C5") & "'"

    Range("E5") = ""

ElseIf rq = 2 Then

    rqstr = "year(出库日期)='" & Range("C5") & "' and month(出库日期)='" & Range("D5") & "'"

ElseIf rq = 3 Then

    rqstr = "year(出库日期)='" & Range("C5") & "' and month(出库日期)='" & Range("D5") & "' and day(出库日期)='" & Range("E5") & "'"

End If

If mc = 0 Then

    mcstr = "1"

Else

    mcstr = "商品代码='" & VBA.Split(Range("F5"), "-")(0) & "'"

End If

If dh = 0 Then

    dhstr = "1"

Else

    dhstr = "出库单号='" & Range("H5") & "'"

End If

str = "( " & rqstr & " ) and ( " & mcstr & " ) and ( " & dhstr & " )"

 mysql = "select * from 出库单 where " & str & " order by 出库日期 desc"

 arr = 执行sql语句筛选(mysql)

 If IsNull(arr) Then

 Else

    arr = Application.WorksheetFunction.Transpose(arr)   

    If 判断数组维数(arr) = 1 Then

        t = 1

    Else

        t = UBound(arr, 1)

    End If

    Range("C8").Resize(t, 7) = arr

    Range("F" & t + 8) = "合计"

    Range("G" & t + 8) = "=sum(G8:G" & t & ")"

    Range("I" & t + 8) = "=sum(I8:I" & t & ")"

End If

Range("H8:I100").NumberFormatLocal = "￥0.00"

End Sub

'******************************出库明细查询End*****************************

'******************************可调用函数Start*****************************

Function 查询条件日期() As Integer

Dim y, m, d

y = Range("C5")

m = Range("D5")

d = Range("E5")

If IsEmpty(y) Then

    查询条件日期 = 0  '不按入库日期查询

    Exit Function

End If

If IsEmpty(m) Then

    查询条件日期 = 1 '按年查询

    Exit Function

End If

If IsEmpty(d) Then

    查询条件日期 = 2 '按月查询

    Exit Function

End If

查询条件日期 = 3 '按日查询

End Function

Function 查询条件商品名称() As Integer

If IsEmpty(Range("F5")) Then

    查询条件商品名称 = 0 '不按商品名称查询

Else

    查询条件商品名称 = 1 '按商品名称查询

End If

End Function

Function 查询条件单号() As Integer

If IsEmpty(Range("H5")) Then

    查询条件单号 = 0 '不按单号查询

Else

    查询条件单号 = 1 '按单号查询

End If

End Function

Sub 更新商品名称()

Dim mysql As String

Dim arr, i As Integer, str As String

mysql = "select * from 代码表"

arr = 执行sql语句筛选(mysql)

If IsNull(arr) Then

    MsgBox "代码表为空"

    Exit Sub

End If

arr = Application.WorksheetFunction.Transpose(arr)

For i = 1 To UBound(arr, 1)

    dmx(arr(i, 1) & "-" & arr(i, 2)) = i

Next i

Range("F5").Validation.Delete

str = VBA.Join(dmx.Keys, ",")

Range("F5").Validation.Add Type:=xlValidateList, Formula1:=str

End Sub

Sub 清空明细查询结果()

Dim r

r = Range("C65536").End(xlUp).Row

If r > 7 Then

    Range("C8:I" & r + 1) = ""

End If

End Sub

'******************************可调用函数End*****************************

(三)出入库汇总查询

1、入库汇总查询事件程序

Private Sub Worksheet_Activate()

Call 生成年月下拉菜单

End Sub

2、出库汇总查询事件程序

Private Sub Worksheet_Activate()

Call 生成年月下拉菜单

End Sub

3、出入库汇总查询模块程序

'******************************入库汇总查询Start*****************************

Sub 入库汇总查询()

Dim rqstart As String

Dim rqend As String

Dim mysql As String

Dim arr

Call 清空汇总查询结果

rqstart = VBA.Join(Array(Range("C5"), Range("D5"), Range("E5")), "-")

rqend = VBA.Join(Array(Range("F5"), Range("G5"), Range("H5")), "-")

mysql = "select first(商品代码) as 商品代码,first(商品名称) as 商品名称,count(入库单号) as 入库单数,sum(入库数量) as 入库总量,sum(入库金额) as 入库总金额 from 入库单 where 入库日期>= #" & rqstart & "# and 入库日期<= #" & rqend & "# group by 商品代码 order by 商品代码 asc"

arr = 执行sql语句筛选(mysql)

If IsNull(arr(0, 0)) Then

    Exit Sub

End If

If 判断数组维数(arr) = 1 Then

    t = 1

Else

    arr = Application.WorksheetFunction.Transpose(arr)

    t = UBound(arr, 1)

End If

Range("D8").Resize(t, 5) = arr

For i = 1 To t

    Range("C7").Offset(i, 0) = i

Next i

Range("F" & 8 + t) = "合计"

Range("G" & 8 + t) = "=sum(G8:G" & 7 + t & ")"

Range("H" & 8 + t) = "=sum(H8:H" & 7 + t & ")"

Range("H8:H" & 8 + t).NumberFormatLocal = "￥0.00"

End Sub

'******************************入库汇总查询End*****************************

'******************************出库汇总查询Start*****************************

Sub 出库汇总查询()

Dim rqstart As String

Dim rqend As String

Dim mysql As String

Dim arr

Call 清空汇总查询结果

rqstart = VBA.Join(Array(Range("C5"), Range("D5"), Range("E5")), "-")

rqend = VBA.Join(Array(Range("F5"), Range("G5"), Range("H5")), "-")

mysql = "select first(商品代码) as 商品代码,first(商品名称) as 商品名称,count(出库单号) as 出库单数,sum(出库数量) as 出库总量,sum(销售金额) as 销售总金额 from 出库单 where 出库日期>= #" & rqstart & "# and 出库日期<= #" & rqend & "# group by 商品代码 order by 商品代码 asc"

arr = 执行sql语句筛选(mysql)

If IsNull(arr(0, 0)) Then

    Exit Sub

End If

If 判断数组维数(arr) = 1 Then

    t = 1

Else

    arr = Application.WorksheetFunction.Transpose(arr)

    t = UBound(arr, 1)

End If

Range("D8").Resize(t, 5) = arr

For i = 1 To t

    Range("C7").Offset(i, 0) = i

Next i

Range("F" & 8 + t) = "合计"

Range("G" & 8 + t) = "=sum(G8:G" & 7 + t & ")"

Range("H" & 8 + t) = "=sum(H8:H" & 7 + t & ")"

Range("H8:H" & 8 + t).NumberFormatLocal = "￥0.00"

End Sub

'******************************出库汇总查询End*****************************

'******************************可调用函数Start*****************************

Sub 生成年月下拉菜单()

Dim ystr As String, mstr As String

Dim i

ystr = "2020"

mstr = "1"

For i = 1 To Year(Date) - 2020

    ystr = ystr & "," & CStr(2020 + i)

Next i

For i = 2 To 12

    mstr = mstr & "," & CStr(i)

Next i

Range("C5,F5,D5,G5").Validation.Delete

Range("C5,F5").Validation.Add Type:=xlValidateList, Formula1:=ystr

Range("D5,G5").Validation.Add Type:=xlValidateList, Formula1:=mstr

End Sub

Sub 清空汇总查询结果()

Dim r

r = Range("C65536").End(xlUp).Row

If r > 7 Then

    Range("C8:H" & r + 1) = ""

End If

End Sub

'******************************可调用函数End*****************************

四、进销存报表

1、进销存报表事件程序

Private Sub Worksheet_Activate()

Call 生成年月下拉菜单

Call 更新进销存商品名称

End Sub

2、进销存报销模块程序

Public djxc As New Dictionary

'******************************生成进销存报表Start*********************************

Sub 生成进销存报表()

Dim rqstart As String

Dim rqend As String

Dim mc

Dim mysqlA As String, mysqlB As String, mysqlC As String, mysqlD As String, mysqlE As String, mysqlF As String, mysqlG As String, mysqlH As String, mysqlI As String, mysqlJ As String

Dim t

rqstart = VBA.Join(Array(Range("C5"), Range("D5"), Range("E5")), "-")

rqend = VBA.Join(Array(Range("F5"), Range("G5"), Range("H5")), "-")

If IsEmpty(Range("I5")) Then

    mc = "1"

Else

    mc = "商品代码='" & VBA.Split(Range("I5"), "-")(0) & "'"

End If

'表1：从代码表筛选出商品代码和商品名称

mysqlA = "select 商品代码,商品名称 from 代码表 where (" & mc & ")"

'表2：从入库单筛选出开始日期之前的商品代码和sum(入库数量)

mysqlB = "select first(商品代码) as 商品代码,sum(入库数量) as 入库总量 from 入库单 where (入库日期<#" & rqstart & "#) and (" & mc & ") group by 商品代码"

'表3：由表1和表2串联形成商品代码、商品名称、期初入库总量

mysqlC = " select 表1.*,iif(isnull(表2.入库总量),0,表2.入库总量) as 入库总量 from (" & mysqlA & ") as 表1 left join (" & mysqlB & ") as 表2 on 表1.商品代码=表2.商品代码"

'表4：从出库单筛选出开始日期之前的商品代码和sum(出库数量)

mysqlD = "select first(商品代码) as 商品代码,sum(出库数量) as 出库总量 from 出库单 where (出库日期<#" & rqstart & "#) and (" & mc & ") group by 商品代码"

'表5：由表3和表4串联形成商品代码、商品名称和期初库存

mysqlE = "select 表3.商品代码,表3.商品名称,(表3.入库总量-iif(isnull(表4.出库总量),0,表4.出库总量)) as 期初库存 from (" & mysqlC & ") as 表3 left join (" & mysqlD & ") as 表4 on 表3.商品代码=表4.商品代码"

'表6：从入库单筛选出日期区间的商品代码和sum(入库数量)

mysqlF = "select first(商品代码) as 商品代码,sum(入库数量) as 当期入库 from 入库单 where (入库日期 between #" & rqstart & "# and #" & rqend & "#) and (" & mc & ") group by 商品代码"

'表7：由表5和表6串联形成商品代码、商品名称、期初库存和当期入库

mysqlG = "select 表5.*,iif(isnull(表6.当期入库),0,表6.当期入库) as 当期入库 from (" & mysqlE & ") as 表5 left join (" & mysqlF & ") as 表6 on 表5.商品代码=表6.商品代码"

'表8：从出库单筛选出日期区间的商品代码和sum(出库数量)

mysqlH = "select first(商品代码) as 商品代码,sum(出库数量) as 当期出库 from 出库单 where (出库日期 between #" & rqstart & "# and #" & rqend & "#) and (" & mc & ") group by 商品代码"

'表9：由表7和表8串联形成商品代码、商品名称、期初库存、当期入库和当期出库

mysqlI = "select 表7.*,iif(isnull(表8.当期出库),0,表8.当期出库) as 当期出库 from (" & mysqlG & ") as 表7 left join (" & mysqlH & ") as 表8 on 表7.商品代码=表8.商品代码"

'表10：由表9形成商品代码、商品名称、期初库存、当期入库、当期出库和期末库存

mysqlJ = "select 表9.*,(表9.期初库存+表9.当期入库-表9.当期出库) as 期末库存 from (" & mysqlI & ") as 表9"

arr = 执行sql语句筛选(mysqlJ)

Call 清空进销存报表查询结果

If IsNull(arr) Then

    Exit Sub

End If

arr = Application.WorksheetFunction.Transpose(arr)

If 判断数组维数(arr) = 1 Then

   t = 1

Else

   t = UBound(arr, 1)

End If

Range("D8").Resize(t, 6) = arr

For i = 1 To t

    Range("C" & 7 + i) = i

Next i

Range("E" & 8 + t) = "合计"

Range("F" & 8 + t) = "=sum(F8:F" & 7 + t & ")"

Range("G" & 8 + t) = "=sum(G8:G" & 7 + t & ")"

Range("H" & 8 + t) = "=sum(H8:H" & 7 + t & ")"

Range("I" & 8 + t) = "=sum(I8:I" & 7 + t & ")"

End Sub

'******************************生成进销存报表End*********************************

'******************************可调用函数Start*********************************

Sub 更新进销存商品名称()

Dim mysql As String

Dim arr, i As Integer, str As String

mysql = "select * from 代码表"

arr = 执行sql语句筛选(mysql)

If IsNull(arr) Then

    MsgBox "代码表为空"

    Exit Sub

End If

arr = Application.WorksheetFunction.Transpose(arr)

For i = 1 To UBound(arr, 1)

    djxc(arr(i, 1) & "-" & arr(i, 2)) = i

Next i

Range("I5").Validation.Delete

str = VBA.Join(djxc.Keys, ",")

Range("I5").Validation.Add Type:=xlValidateList, Formula1:=str

End Sub

Sub 清空进销存报表查询结果()

Dim r

r = Range("C65536").End(xlUp).Row

If r < 8 Then

    Exit Sub

End If

Range("C8:I" & r + 1) = ""

End Sub

'******************************可调用函End*********************************

四、进销存管理系统下载链接

在Excel中用vba编写的进销存管理系统-管理软件文档类资源-CSDN下载

内包含2个文件：1、进销存管理系统.xlsm；2、仓库数据.accdb；其中仓库数据.accdb为进销存管理系统所对应的Access数据库文件。注意，请将“仓库数据.accdb”放于D盘根目录下。