vba编写的出库单（可添加出库项目记录、生成、打印出库单）

一、操作界面

二、使用说明

使用说明：

1、出库单号由8位出库日期和3位序列号组成，如20220606001；

2、出库单号只需填写序列号（1~999）；

3、当出库日期更新或出库单号不符合规则时，出库单号显示为系统默认可用序列号；

4、点击"添加"，将出库信息添加到出库清单

5、点击"生成"，生成出库单

6、选中出库清单中的记录，点击右键，可以删除该记录

7、双击出库清单，可以清空出库单中记录

三、vba代码

Private Sub UserForm_Initialize()

 Dim w

 Me.MultiPage_多页框架.Value = 0

 Me.MultiPage_多页框架.Style = fmTabStyleNone

 Me.DTPicker_出库日期.Value = VBA.Date

 Me.TextBox_出库单号.MaxLength = 3

 Me.TextBox_出库单号.Text = VBA.Format(1, "000")

 ODONumberUpdate '更新出库单号

 Me.TextBox_出库单号.SetFocus

 PriceListTree   '生成价格表

 w = Me.ListView_出库清单.Width

 Me.ListView_出库清单.ColumnHeaders.Add 1, "C1", "销售日期", w / 8 - 1

 Me.ListView_出库清单.ColumnHeaders.Add 2, "C2", "出库单号", w / 8 - 1, lvwColumnCenter

 Me.ListView_出库清单.ColumnHeaders.Add 3, "C3", "商品代码", w / 8 - 1, lvwColumnCenter

 Me.ListView_出库清单.ColumnHeaders.Add 4, "C4", "商品名称", w / 8 - 1, lvwColumnCenter

 Me.ListView_出库清单.ColumnHeaders.Add 5, "C5", "型号", w / 8 - 1, lvwColumnCenter

 Me.ListView_出库清单.ColumnHeaders.Add 6, "C6", "销售数量", w / 8 - 1, lvwColumnCenter

 Me.ListView_出库清单.ColumnHeaders.Add 7, "C7", "销售单价", w / 8 - 1, lvwColumnCenter

 Me.ListView_出库清单.ColumnHeaders.Add 8, "C8", "销售金额", w / 8 - 1, lvwColumnCenter

 Me.ListView_出库清单.FullRowSelect = True

 Me.ListView_出库清单.Gridlines = True

 Me.ListView_出库清单.View = lvwReport

 End Sub

Private Sub CommandButton_打印_Click()

Dim sh As Worksheet, i As Integer, r As Integer

Set sh = Sheets("出库单")

r = sh.Range("B2").CurrentRegion.Rows.Count + 1

If r < 6 Then

    MsgBox prompt:="出库清单为空，不能打印", Buttons:=vbOKOnly + vbInformation, Title:="提示"

    Exit Sub

End If

sh.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False

End Sub

Private Sub CommandButton_商品代码_Click()

Me.MultiPage_多页框架.Value = 1

End Sub

Private Sub CommandButton_生成_Click()

Dim sh As Worksheet, iItem As Object

Dim r As Integer, i As Integer, j As Integer

Set sh = Sheets("出库")

r = sh.Range("A1").CurrentRegion.Rows.Count

For i = 1 To Me.ListView_出库清单.ListItems.Count Step 1

    Set iItem = Me.ListView_出库清单.ListItems(i)

    sh.Cells(r + i, 1) = iItem.Text

    For j = 1 To Me.ListView_出库清单.ColumnHeaders.Count - 1 Step 1

        sh.Cells(r + i, j + 1) = iItem.SubItems(j)

    Next j

Next i

bl = 生成出库单

If bl Then

    MsgBox "出库单已生成"

End If

End Sub

Private Sub CommandButton_添加_Click()

Dim st, ans

Dim iItem As Object

st = Me.TextBox_出库单号.Text

If st = "" Then

     MsgBox prompt:="出库单号不能为空，出库单号应为1~999", Buttons:=vbOKOnly + vbInformation, Title:="提示"

     Call ODONumberUpdate    '更新出库单号

     Exit Sub

End If

If ODONumberIsExist Then

  ans = MsgBox(prompt:="出库单号" & st & "已存在，建议更改为系统推荐单号，是否接受？", Buttons:=vbYesNo + vbQuestion, Title:="询问")

  If ans = vbYes Then

    ODONumberUpdate

  Else

    Me.TextBox_出库单号.SetFocus

    Exit Sub

  End If

End If

'同一出库单，出库单号是否一致

If Me.ListView_出库清单.ListItems.Count > 0 Then

    If VBA.Format(Me.ListView_出库清单.ListItems(1).Text, "yyyymmdd") <> VBA.Format(Me.DTPicker_出库日期.Value, "yyyymmdd") Then

        MsgBox prompt:="出库日期不一致!", Buttons:=vbOKOnly + vbExclamation, Title:="警告"

        Exit Sub

    End If

    If VBA.Right(Me.ListView_出库清单.ListItems(1).SubItems(1), 3) * 1 <> Me.TextBox_出库单号.Text * 1 Then

       MsgBox prompt:="出库单号不一致!", Buttons:=vbOKOnly + vbExclamation, Title:="警告"

       Exit Sub

    End If

End If

'记录要完整

If Me.TextBox_销售金额.Text = "" Then

    MsgBox prompt:="出库信息不完整!", Buttons:=vbOKOnly + vbExclamation, Title:="警告"

    Exit Sub

End If

Set iItem = Me.ListView_出库清单.ListItems.Add()

iItem.Text = VBA.Format(Me.DTPicker_出库日期.Value, "yyyy-mm-dd")

iItem.SubItems(1) = VBA.Format(Me.DTPicker_出库日期.Value, "yyyymmdd") & VBA.Format(Me.TextBox_出库单号.Text, "000")

iItem.SubItems(2) = Me.TextBox_商品代码.Text

iItem.SubItems(3) = Me.TextBox_商品名称.Text

iItem.SubItems(4) = Me.TextBox_型号.Text

iItem.SubItems(5) = Me.TextBox_销售数量.Text

iItem.SubItems(6) = Me.TextBox_销售单价.Text

iItem.SubItems(7) = Me.TextBox_销售金额.Text

End Sub

Private Sub DTPicker_出库日期_Change()

ODONumberUpdate '更新出库单号

End Sub

Private Sub Label_使用说明_Click()

End Sub

Private Sub ListView_出库清单_DblClick() '双击清空所有记录

Dim ans

ans = MsgBox(prompt:="确定要清空所有记录吗？", Buttons:=vbYesNo + vbQuestion, Title:="询问")

If ans = vbYes Then

    Me.ListView_出库清单.ListItems.Clear

End If

End Sub

Private Sub ListView_出库清单_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS)

If Button = 2 Then '按下鼠标右键

    ans = MsgBox(prompt:="确定要删除此条记录吗？", Buttons:=vbYesNo + vbQuestion, Title:="询问")

    If ans = vbYes Then

        Me.ListView_出库清单.ListItems.Remove Me.ListView_出库清单.SelectedItem.Index

    End If

End If

End Sub

Private Sub SpinButton_出库单号_SpinDown()

Dim iODONumber As Integer

iODONumber = Me.TextBox_出库单号.Text * 1 - 1

If iODONumber < 1 Then

    iODONumber = 1

End If

Me.TextBox_出库单号.Text = VBA.Format(iODONumber, "000")

End Sub

Private Sub SpinButton_出库单号_SpinUp()

Dim iODONumber As Integer

iODONumber = Me.TextBox_出库单号.Text * 1 + 1

If iODONumber > 999 Then

    iODONumber = 999

End If

Me.TextBox_出库单号.Text = VBA.Format(iODONumber, "000")

End Sub

Private Sub TextBox_出库单号_Exit(ByVal Cancel As MSForms.ReturnBoolean)

Dim iODONumber As Integer

'出库单号不能为空

If Me.TextBox_出库单号.Text = "" Then

    MsgBox prompt:="出库单号不能为空，出库单号应为1~999", Buttons:=vbOKOnly + vbInformation, Title:="提示"

    ODONumberUpdate '更新出库单号

    Exit Sub

End If

'出库单号必须为数字

If VBA.IsNumeric(Me.TextBox_出库单号.Text) And Me.TextBox_出库单号.Text <> "" Then

Else

    MsgBox prompt:="出库单号格式不正确，出库单号应为1~999", Buttons:=vbOKOnly + vbInformation, Title:="提示"

    ODONumberUpdate '更新出库单号

    Exit Sub

End If

'出库单号为整数

iODONumber = VBA.Int(Me.TextBox_出库单号.Text)

If iODONumber <> Me.TextBox_出库单号.Text * 1 Then

    MsgBox prompt:="出库单号应为整数，出库单号应为1~999", Buttons:=vbOKOnly + vbInformation, Title:="提示"

    ODONumberUpdate '更新出库单号

    Exit Sub

End If

'出库单号范围1~999

If iODONumber < 1 Or iODONumber > 999 Then

    MsgBox prompt:="出库单号超出范围，出库单号应为1~999", Buttons:=vbOKOnly + vbInformation, Title:="提示"

    ODONumberUpdate '更新出库单号

    Exit Sub

End If

Me.TextBox_出库单号.Text = VBA.Format(iODONumber, "000")

End Sub

Private Sub TextBox_商品代码_Change()

Dim f As Integer, iID

Dim iNode As Node

iID = Me.TextBox_商品代码.Text

f = 0

For Each iNode In Me.TreeView_价格表.Nodes

    If VBA.Len(iID) > 1 And iID = iNode.Key Then

        f = 1

        Exit For

    End If

Next iNode

If f = 1 Then

    If VBA.Left(iNode.Key, 1) = "A" Then

        Me.TextBox_商品名称.Text = "电视"

        Me.TextBox_型号.Text = VBA.Right(iNode.Key, 3) * 1 & "寸"

    ElseIf VBA.Left(iNode.Key, 1) = "B" Then

        Me.TextBox_商品名称.Text = "洗衣机"

        Me.TextBox_型号.Text = VBA.Right(iNode.Key, 3) * 1 & "升"

    ElseIf VBA.Left(iNode.Key, 1) = "C" Then

        Me.TextBox_商品名称.Text = "空调"

        Me.TextBox_型号.Text = VBA.Right(iNode.Key, 3) * 1 & "匹"

    End If

    Me.TextBox_销售单价.Text = VBA.Split(iNode.Text, "：")(1)

    If VBA.IsNumeric(Me.TextBox_销售数量) Then

        Me.TextBox_销售金额.Text = VBA.Format(Me.TextBox_销售数量 * Me.TextBox_销售单价, "￥#,##0")

    Else

        Me.TextBox_销售数量.Text = ""

    End If

Else

    Me.TextBox_商品名称.Text = ""

    Me.TextBox_型号.Text = ""

    Me.TextBox_销售单价.Text = ""

    Me.TextBox_销售金额.Text = ""

End If

End Sub

Private Sub TextBox_商品代码_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

Me.MultiPage_多页框架.Value = 1

End Sub

Private Sub TextBox_商品代码_Exit(ByVal Cancel As MSForms.ReturnBoolean)

Dim iID, f As Integer

Dim iNode As Node

iID = Me.TextBox_商品代码.Text

f = 0

For Each iNode In Me.TreeView_价格表.Nodes

    If VBA.Len(iID) > 1 And iID = iNode.Key Then

        f = 1

        Exit For

    End If

Next iNode

If f = 1 Then

    If VBA.Left(iNode.Key, 1) = "A" Then

        Me.TextBox_商品名称.Text = "电视"

        Me.TextBox_型号.Text = VBA.Right(iNode.Key, 3) * 1 & "寸"

    ElseIf VBA.Left(iNode.Key, 1) = "B" Then

        Me.TextBox_商品名称.Text = "洗衣机"

        Me.TextBox_型号.Text = VBA.Right(iNode.Key, 3) * 1 & "升"

    ElseIf VBA.Left(iNode.Key, 1) = "C" Then

        Me.TextBox_商品名称.Text = "空调"

        Me.TextBox_型号.Text = VBA.Right(iNode.Key, 3) * 1 & "匹"

    End If

    Me.TextBox_销售单价.Text = VBA.Split(iNode.Text, "：")(1)

    If VBA.IsNumeric(Me.TextBox_销售数量) Then

        Me.TextBox_销售金额.Text = VBA.Format(Me.TextBox_销售数量 * Me.TextBox_销售单价, "￥#,##0")

    Else

        Me.TextBox_销售数量.Text = ""

    End If

Else

    If VBA.Len(iID) > 0 Then

        MsgBox prompt:="此商品代码不存在", Buttons:=vbOKOnly + vbInformation, Title:="提示"

    End If

    Me.TextBox_商品名称.Text = ""

    Me.TextBox_型号.Text = ""

    Me.TextBox_销售单价.Text = ""

    Me.TextBox_销售金额.Text = ""

End If

Set iNode = Nothing

End Sub

Private Sub TextBox_销售数量_Change()

If VBA.IsNumeric(Me.TextBox_销售数量.Text) Then

    If Me.TextBox_销售单价.Text <> "" Then

        Me.TextBox_销售金额.Text = VBA.Format(Me.TextBox_销售数量 * Me.TextBox_销售单价, "￥#,##0")

    Else

        Me.TextBox_销售金额.Text = ""

    End If

Else

    If VBA.Len(Me.TextBox_销售数量.Text) > 0 Then

        MsgBox prompt:="销售数量格式不正确", Buttons:=vbOKOnly + vbInformation, Title:="提示"

    End If

    Me.TextBox_销售金额.Text = ""

End If

End Sub

Private Sub TreeView_价格表_NodeClick(ByVal Node As MSComctlLib.Node)

If VBA.Len(Node.Key) > 1 Then

    Me.TextBox_商品代码.Text = Node.Key

    Me.TextBox_商品名称.Text = Node.Parent.Text

    If Node.Parent.Key = "A" Then

        Me.TextBox_型号.Text = VBA.Right(Node.Key, 3) * 1 & "寸"

    ElseIf Node.Parent.Key = "B" Then

         Me.TextBox_型号.Text = VBA.Right(Node.Key, 3) * 1 & "升"

    ElseIf Node.Parent.Key = "C" Then

         Me.TextBox_型号.Text = VBA.Right(Node.Key, 3) * 1 & "匹"

    End If

    Me.TextBox_销售单价.Text = VBA.Split(Node.Text, "：")(1)

    If VBA.IsNumeric(Me.TextBox_销售数量.Text) Then

        Me.TextBox_销售金额.Text = VBA.Format(Me.TextBox_销售数量.Text * Me.TextBox_销售单价.Text, "￥#,##0")

    Else

        Me.TextBox_销售金额.Text = ""

    End If

End If

Me.MultiPage_多页框架.Value = 0

End Sub

'***************************更新出库单号 start *****************************

Sub ODONumberUpdate()  '更新出库单号

Dim iDateODONumberArr

Dim imyDate, i As Integer

imyDate = VBA.Format(Me.DTPicker_出库日期.Value, "yyyymmdd")

iDateODONumberArr = DateODONumberArr(imyDate)

If VBA.IsArray(iDateODONumberArr) Then

    i = Application.WorksheetFunction.Max(iDateODONumberArr) + 1

Else

    i = 1

End If

Me.TextBox_出库单号.Text = VBA.Format(i, "000")

End Sub

Function DateODONumberArr(ByVal myDate)   '某日已出库单号数组

Dim iODONumberArr, iDateODONumberArr

Dim sh As Worksheet, r As Integer

Dim i As Integer, ar

Set sh = Sheets("出库")

r = sh.Range("A1").CurrentRegion.Rows.Count

iODONumberArr = Application.WorksheetFunction.Transpose(sh.Range("B1").Resize(r, 1))

i = 0

For Each ar In iODONumberArr

    If ar Like myDate & "###" Then

        i = i + 1

        If i = 1 Then

            ReDim iDateODONumberArr(1 To i)

        Else

            ReDim iDateODONumberArr(1 To i)

        End If

        iDateODONumberArr(i) = VBA.Val(VBA.Right(ar, 3))

    End If

Next ar

DateODONumberArr = iDateODONumberArr

End Function

'***************************更新出库单号 end *****************************

'***************************生成价格表 start *****************************

Sub PriceListTree()

Dim sh As Worksheet

Dim PriceListArr

Dim iRelative, iRelationShip, iKey, iText, iImage

Dim i As Integer

Dim iNode As Node

Set sh = Sheets("价格表")

PriceListArr = sh.Range("A1").CurrentRegion

Me.TreeView_价格表.ImageList = Me.ImageList_图标集

Me.TreeView_价格表.Nodes.Add , , "A", "电视", 1

Me.TreeView_价格表.Nodes.Add , , "B", "洗衣机", 3

Me.TreeView_价格表.Nodes.Add , , "C", "空调", 5

For i = 2 To UBound(PriceListArr, 1) Step 1

    iRelative = VBA.Left(PriceListArr(i, 1), 1)

    iRelationShip = tvwChild

    iKey = PriceListArr(i, 1)

    iText = PriceListArr(i, 1) & "(" & PriceListArr(i, 3) & ")" & "价格：" & VBA.Format(PriceListArr(i, 4), "￥#,##0")

    If iRelative = "A" Then

        iImage = 2

    ElseIf iRelative = "B" Then

        iImage = 4

    ElseIf iRelative = "C" Then

        iImage = 6

    End If

    Set iNode = Me.TreeView_价格表.Nodes.Add(iRelative, iRelationShip, iKey, iText, iImage)

    iNode.EnsureVisible

Next i

End Sub

'***************************生成价格表 end *****************************

'***************************出库单号是否已存在 start *****************************

Function ODONumberIsExist() As Boolean

Dim bl As Boolean

Dim iODONumber, iODONumberArr

Dim r As Integer

Dim sh As Worksheet, f

iODONumber = VBA.Val(VBA.Format(Me.DTPicker_出库日期.Value, "yyyymmdd") & Me.TextBox_出库单号.Text)

Set sh = Sheets("出库")

r = sh.Range("A1").CurrentRegion.Rows.Count

iODONumberArr = Application.WorksheetFunction.Transpose(sh.Range("B1").Resize(r, 1))

On Error Resume Next

f = Application.WorksheetFunction.Match(iODONumber, iODONumberArr, 0)

If f = "" Then

    bl = False

Else

    bl = True

End If

ODONumberIsExist = bl

End Function

'***************************出库单号是否已存在 end *****************************

'***************************生成出库单 strart *****************************

Function 生成出库单() As Boolean

Dim sh As Worksheet, i As Integer, r As Integer

Set sh = Sheets("出库单")

r = sh.Range("B2").CurrentRegion.Rows.Count + 1

If r > 5 Then

    sh.Range("A6").Resize(r - 5, 1).EntireRow.Delete

End If

If Me.ListView_出库清单.ListItems.Count = 0 Then

    MsgBox prompt:="出库清单为空，不能打印", Buttons:=vbOKOnly + vbInformation, Title:="提示"

    生成出库单 = False

    Exit Function

End If

Set sh = Sheets("出库单")

sh.Range("C4") = Me.ListView_出库清单.ListItems(1).Text

sh.Range("F4") = Me.ListView_出库清单.ListItems(1).SubItems(1)

For i = 1 To Me.ListView_出库清单.ListItems.Count Step 1

    sh.Cells(5 + i, 2) = Me.ListView_出库清单.ListItems(i).SubItems(2)

    sh.Cells(5 + i, 3) = Me.ListView_出库清单.ListItems(i).SubItems(3)

    sh.Cells(5 + i, 4) = Me.ListView_出库清单.ListItems(i).SubItems(4)

    sh.Cells(5 + i, 5) = Me.ListView_出库清单.ListItems(i).SubItems(5)

    sh.Cells(5 + i, 6) = Me.ListView_出库清单.ListItems(i).SubItems(6)

    sh.Cells(5 + i, 7) = Me.ListView_出库清单.ListItems(i).SubItems(7)

Next i

r = sh.Range("B2").CurrentRegion.Rows.Count + 1

sh.Range("B6").Resize(r - 5, 6).Borders.LineStyle = xlContinuous '设置边框

生成出库单 = True

End Function

'***************************生成出库单 end *****************************

四、小程序下载

https://download.csdn.net/download/aaron19822007/85581241