VBA【代码】送货单、销售单：分享一个功能强大的纯EXCEL版数据录入、保存、修改、打印模板！
发布日期：2025-04-12 14:28 点击次数：142
内容提要
送货单|完整代码
1、在工作表“送货单”里，命令按钮点击事件，工作表Change事件、Selection Change事件，自定义过程、函数：
Dim arr(), arrtemp(), DeliverNumber As StringPrivate Sub CmdAddNew_Click() Call clsRG.clearData Call updateDeliverNumberEnd SubPrivate Sub CmdPrint_Click() Call printWorksheetEnd SubPrivate Sub CmdRefresh_Click() Call updateDeliverNumberEnd SubPrivate Sub CmdSave_Click() If clsDQ.IsDeliverNumberExists(clsRG.送货单号) Then MsgBox "单据号已存在，请更新单据号后再保存！" Exit Sub End If processType = "新增保存" Call saveNewEnd SubPrivate Sub CmdSaveAndPrint_Click() If clsDQ.IsDeliverNumberExists(clsRG.送货单号) Then MsgBox "单据号已存在，请更新单据号后再保存！" Exit Sub End If processType = "新增保存" Call printWorksheet Call saveNew End SubPrivate Sub CmdClear_Click() clsRG.clearDataEnd SubPrivate Sub CmdUpdate_Click() If Not clsDQ.IsDeliverNumberExists(clsRG.送货单号) Then MsgBox "单据号不存在，无法更新！" Exit Sub End If processType = "更新保存" Call saveNewEnd SubPrivate Sub CmdUpdateAndPrint_Click() If Not clsDQ.IsDeliverNumberExists(clsRG.送货单号) Then MsgBox "单据号不存在，无法更新！" Exit Sub End If processType = "更新保存" Call printWorksheet Call saveNewEnd SubPrivate Sub Worksheet_Activate() If dbs = "" Then dbs = ThisWorkbook.FullName End IfEnd SubPrivate Sub Worksheet_Change(ByVal Target As Range) Dim arr(), rng As Range Dim DeliverNumber As String, customer As String Dim currRow As Integer, currCol As Integer Dim targetCol As Integer '//日期与单据号，如果是新日期，更新单据号； '//否则根据单据号读取数据 If Target.Address = clsRG.日期.MergeArea.Address Then If blnUpdateDeliverNumber Then Call updateDeliverNumber Else blnUpdateDeliverNumber = True End If End If If Target.Address = clsRG.送货单号.Address Then tbl = "[数据$]" DeliverNumber = Target.Value If clsDQ.IsDeliverNumberExists(DeliverNumber) Then blnUpdateDeliverNumber = False Set rng = clsRG.数据区域 rng.ClearContents sql = "select * from " & tbl & " where 送货单号='" & DeliverNumber & "'" arr = clsDQ.getData(sql) customer = arr(2, 0) clsRG.日期 = arr(1, 0) clsRG.客户名称 = customer clsRG.收货地址 = getCustomerAddress(customer) With rng For i = 0 To UBound(arr, 2) .Cells(i + 1, 1) = i + 1 For j = 4 To UBound(arr) .Cells(i + 1, j - 2) = arr(j, i) Next Next End With blnUpdateDeliverNumber = True End If End If '//流水号根据序号自动生成,当单据号存在的时候，不自动修改流水号 '//自动填写序号，当物料名称填写之后 If Not Intersect(Target, clsRG.物料名称) Is Nothing And Target.CountLarge = 1 Then Target.Offset(0, -1) = Target.Row - 6 End If If Not Intersect(Target, clsRG.序号) Is Nothing And Target.CountLarge = 1 Then If Application.WorksheetFunction.CountIf(clsRG.序号, Target.Value) > 1 Then MsgBox "序号重复，请重新输入！" Target.ClearContents Exit Sub End If targetCol = clsRG.流水号.Column - 1 DeliverNumber = clsRG.送货单号 If Not clsDQ.IsDeliverNumberExists(DeliverNumber) Then If Target.Value > 0 Then Target.Offset(0, targetCol).Value = clsRG.送货单号 & Format(Target, "00") Else Target.Offset(0, targetCol).Value = "" End If End If End If '//数量、单价Change，重算金额、合计数 If Not Intersect(Target, clsRG.数量) Is Nothing And Target.CountLarge = 1 Then '//检查一下 If IsNumeric(Target.Value) = False Then MsgBox "数量只能输入数字,请重新输入！" Target.ClearContents Exit Sub End If '//金额 Target.Offset(0, 2).Value = Target.Value * Target.Offset(0, 1).Value '//箱数 q = getPCS(CStr(Target.Offset(0, -4).Value)) If q > 0 Then Target.Offset(0, 3) = Application.WorksheetFunction.RoundUp(Target.Value / q, 0) End If clsRG.数量合计 = Application.WorksheetFunction.Sum(clsRG.数量) clsRG.金额合计 = Application.WorksheetFunction.Sum(clsRG.金额) clsRG.箱数合计 = Application.WorksheetFunction.Sum(clsRG.箱数) End If If Not Intersect(Target, clsRG.单价) Is Nothing And Target.CountLarge = 1 Then '//检查一下 If IsNumeric(Target.Value) = False Then MsgBox "单价只能输入数字,请重新输入！" Target.ClearContents Exit Sub End If Target.Offset(0, 1).Value = Target.Value * Target.Offset(0, -1).Value clsRG.金额合计 = Application.WorksheetFunction.Sum(clsRG.金额) End If End SubPrivate Function getCustomerAddress(customer As String) Dim arr() sql = "select 收货地址 from [客户档案$] where 客户名称='" & customer & " '" On Error Resume Next arr = clsDQ.getData(sql) On Error GoTo 0 If Not IsArrEmpty(arr) Then getCustomerAddress = arr(0, 0) Else getCustomerAddress = "" End IfEnd FunctionPrivate Sub Worksheet_SelectionChange(ByVal Target As Range) 'On Error Resume Next Dim iRow As Integer, iCol As Integer Dim iWidth As Single '//客户名称 Dim ws As Worksheet, currRow As Integer, lastRow As Integer Dim arr(), dic As Object, dkey As String Set dic = CreateObject("Scripting.Dictionary") dbs = ThisWorkbook.FullName tbl = "[数据$]" dkey = Target.Address currRow = Target.Row If Target.Address = clsRG.客户名称.MergeArea.Address Then sql = "select distinct 客户名称,收货地址 from [客户档案$] where isnull(客户名称)=false" arr = clsDQ.getData(sql) iWidth = Range("B3:D3").Width Call setTextBox(Target, iWidth, 3, arr) ElseIf Target.Address = clsRG.送货单号.MergeArea.Address Then sql = "select distinct 送货单号 from [数据$] where isnull(送货单号)=false order by 送货单号 DESC" arr = clsDQ.getData(sql) iWidth = Target.Width Call setTextBox(Target, iWidth, 1, arr) ElseIf Not Intersect(Target, clsRG.物料名称) Is Nothing And Target.CountLarge = 1 Then sql = "select distinct 物料名称,规格,加工说明,单位,0 as 数量,单价 from [物料明细$] " arr = clsDQ.getData(sql) 'iWidth = clsRG.数据区域.Width - clsRG.数据区域.Columns(1).Width For i = 2 To 7 iWidth = iWidth + Columns(i).Width Next Call setTextBox(Target, iWidth, 6, arr) Else Me.TextBox1.Visible = False Me.TextBox1 = "" Me.ListBox1.Visible = False Me.ListBox1.Clear End If End SubPrivate Sub setTextBox(Target As Range, iWidth As Single, iCols As Integer, arr()) Dim iRow As Integer, iCol As Integer On Error Resume Next iRow = UBound(arr) iCol = UBound(arr, 2) On Error GoTo 0 If iCol = 0 Then arrtemp = Application.WorksheetFunction.Transpose(arr) Else ReDim arrtemp(0 To iCol, 0 To iRow) For i = 0 To iCol For j = 0 To iRow arrtemp(i, j) = arr(j, i) Next Next End If With Me.TextBox1 .Visible = True .Top = Target.Top + Target.Height .Left = Target.Left .Width = Target.Width .Height = Target.Height With Me.ListBox1 .Visible = True .Top = Me.TextBox1.Top + Me.TextBox1.Height .Left = Me.TextBox1.Left .Width = iWidth .ColumnCount = iCols .List = arrtemp .Height = 30 + (.ListCount - 1) * 12 If .Height > 100 Then .Height = 100 End If End With End With End SubPrivate Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) With ListBox1 If Selection.Address = clsRG.客户名称.MergeArea.Address Then clsRG.客户名称 = .List(.ListIndex, 0) clsRG.收货地址 = .List(.ListIndex, 1) ElseIf Selection.Address = clsRG.送货单号.MergeArea.Address Then clsRG.送货单号 = .List(.ListIndex) ElseIf Not Intersect(Selection, clsRG.物料名称) Is Nothing Then For i = 2 To 7 Cells(Selection.Row, i) = .List(.ListIndex, i - 2) Next End If End With Me.TextBox1.Visible = False Me.TextBox1 = "" Me.ListBox1.Visible = False Me.ListBox1.Clear 'clsRG.数据区域.Cells(1, 2).Select End SubPrivate Function getPCS(material As String) '//一箱装多少件 Dim arr() sql = "select 每箱件数 from [物料明细$] where 物料名称='" & material & "'" On Error Resume Next arr = clsDQ.getData(sql) On Error GoTo 0 If Not IsEmpty(arr) Then getPCS = arr(0, 0) Else getPCS = 0 End IfEnd FunctionPrivate Sub TextBox1_Change() Dim arr(), arrtemp(), sql As String Dim currRow As Integer Dim txbValue As String On Error Resume Next currRow = ActiveCell.Row txbValue = Me.TextBox1 If Selection.Address = clsRG.客户名称.MergeArea.Address Then sql = "SELECT 客户名称,收货地址 FROM [客户档案$] WHERE 客户名称 LIKE '%" & txbValue & "%' " _ & "OR 收货地址 LIKE '%" & txbValue & "%' " _ & "ORDER BY 客户名称 ASC" arr = clsDQ.getData(sql) Call setListBox(arr) ElseIf Selection.Address = clsRG.送货单号.MergeArea.Address Then sql = "select distinct 送货单号 from [数据$] where 送货单号 LIKE '%" & txbValue & "%' order by 送货单号 DESC" arr = clsDQ.getData(sql) Call setListBox(arr) ElseIf Not Intersect(Target, clsRG.物料名称) Is Nothing And Target.CountLarge = 1 Then sql = "select distinct 物料名称,规格,加工说明,单位,0 as 数量,单价 from [物料明细$] WHERE 物料名称 LIKE '%" & txbValue & "%' " _ & "OR 规格 LIKE '%" & txbValue & "%' " _ & "OR 加工说明 LIKE '%" & txbValue & "%' order by 物料名称" arr = clsDQ.getData(sql) Call setListBox(arr) End If End SubPrivate Sub setListBox(arr()) Dim iRow As Integer, iCol As Integer, t As Integer On Error GoTo Er iRow = UBound(arr) iCol = UBound(arr, 2) GoTo PrEr: t = 1Pr: If t = 1 Then arrtemp = Application.WorksheetFunction.Transpose(arr) Else ReDim arrtemp(0 To iCol, 0 To iRow) For i = 0 To iCol For j = 0 To iRow arrtemp(i, j) = arr(j, i) Next Next End If With ListBox1 .Clear .List = arrtemp .Height = 30 + (.ListCount - 1) * 12 If .Height > 100 Then .Height = 100 End If End WithEnd SubPrivate Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) '//检查是否按下了 ESC 键,在textBox中输入时，如果习惯按Esc取消输入法编码，代码会中断 If KeyCode = 27 Then KeyCode = 0 End IfEnd Sub2、在用户窗体Usf_DateSelect里，日期控件相关代码：
Private Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As LongPrivate clsDC As New DateControlPrivate co As New Collection'Public sLabelName As String'Dim myDate As DateDim arrWeek As Variant '星期几Dim arrForeColor As Variant '前景色(文本颜色)'窗体加载Private Sub UserForm_Initialize() Dim clsCommandButton As MSForms.CommandButton Dim clsComboBox As MSForms.ComboBox Me.BackColor = RGB(147, 112, 219) '添加 年列表 左按钮 Set clsCommandButton = Me.Controls.Add("Forms.CommandButton.1", "YearDecrease") With clsCommandButton .Width = 15 .Height = 15 .Caption = ChrW(&H25C0) .Font.Size = 7 .ForeColor = vbBlue .BackStyle = 0 End With clsDC.ReceiveCommandButton clsCommandButton co.Add clsDC Set clsDC = Nothing '添加 年列表 Set clsComboBox = Me.Controls.Add("Forms.ComboBox.1", "CmbYear") With clsComboBox For i = 1900 To 2999 .AddItem i Next .Left = Me.Controls("YearDecrease").Left + Me.Controls("YearDecrease").Width .Width = 45 .Height = 15 .Value = Year(myDate) .Font.Size = 11 .ListWidth = 50 '.ColumnWidths = 18 '.Style = fmStyleDropDownList .TextAlign = fmTextAlignLeft End With clsDC.ReceiveComboBox clsComboBox co.Add clsDC Set clsDC = Nothing '添加 年列表 右按钮 Set clsCommandButton = Me.Controls.Add("Forms.CommandButton.1", "YearIncrease") With clsCommandButton .Left = Me.Controls("CmbYear").Left + Me.Controls("CmbYear").Width .Width = 15 .Height = 15 .Caption = ChrW(&H25B6) .Font.Size = 7 .ForeColor = vbBlue .BackStyle = 0 End With clsDC.ReceiveCommandButton clsCommandButton co.Add clsDC Set clsDC = Nothing '添加 月列表 左按钮 Set clsCommandButton = Me.Controls.Add("Forms.CommandButton.1", "MonthDecrease") With clsCommandButton .Left = Me.Controls("YearIncrease").Left + Me.Controls("YearIncrease").Width + 2 .Width = 15 .Height = 15 .Caption = ChrW(&H25C0) .Font.Size = 7 .ForeColor = RGB(100, 149, 237) .BackStyle = 0 End With clsDC.ReceiveCommandButton clsCommandButton co.Add clsDC Set clsDC = Nothing '添加 月列表 Set clsComboBox = Me.Controls.Add("Forms.ComboBox.1", "CmbMonth") With clsComboBox For i = 1 To 12 .AddItem i Next .Left = Me.Controls("MonthDecrease").Left + Me.Controls("MonthDecrease").Width .Width = 35 .Height = 15 .Value = Month(myDate) .Font.Size = 11 .ListWidth = 35 '.ColumnWidths = 18 End With clsDC.ReceiveComboBox clsComboBox co.Add clsDC Set clsDC = Nothing '添加 月列表 右按钮 Set clsCommandButton = Me.Controls.Add("Forms.CommandButton.1", "MonthIncrease") With clsCommandButton .Left = Me.Controls("CmbMonth").Left + Me.Controls("CmbMonth").Width .Width = 15 .Height = 15 .Caption = ChrW(&H25B6) .Font.Size = 7 .ForeColor = RGB(100, 149, 237) .BackStyle = 0 End With clsDC.ReceiveCommandButton clsCommandButton co.Add clsDC Set clsDC = Nothing Me.Width = Me.Controls("MonthIncrease").Left + Me.Controls("MonthIncrease").Width arrWeek = Array("日", "一", "二", "三", "四", "五", "六") '初始化 星期几 数组 '初始化 Label 前景色 arrForeColor = Array(vbRed, 0, 0, 0, 0, 0, vbRed) '添加星期标签 For i = LBound(arrWeek) To UBound(arrWeek) With Me.Controls.Add("Forms.Label.1", arrWeek(i)) .Top = 17 .Left = i * 20 + 1.5 .Width = 20 .Height = 11 .Caption = arrWeek(i) .TextAlign = fmTextAlignCenter .BackColor = RGB(176, 196, 222) .ForeColor = arrForeColor(i)' .BorderStyle = fmBorderStyleSingle End With Next AddLabel_Day Date End Sub'添加日期标签Public Sub AddLabel_Day(ByVal myDate As Date) Dim iCol As Integer '列标 Dim iRow As Integer '行标 Dim arrForeColor As Variant '前景色(文本颜色) Dim datStartDay As Date '开始日期 Dim datLastDay As Date '结尾日期 Dim clsLabel As Control '删除原有的日期标签 For Each clsLabel In Controls If clsLabel.Name Like "LbDay*" Then Controls.Remove clsLabel.Name Next arrForeColor = Array(vbRed, 0, 0, 0, 0, 0, vbRed) '初始化 Label 前景色 datStartDay = DateSerial(Year(myDate), Month(myDate), 1) datStartDay = datStartDay - WeekDay(datStartDay) + 1 '取得开始日期 datLastDay = DateSerial(Year(myDate), Month(myDate) + 1, 0) datLastDay = datLastDay + 7 - WeekDay(datLastDay) '取得结尾日期 For i = datStartDay To datLastDay iCol = (i - datStartDay) Mod 7 iRow = Int((i - datStartDay) / 7) Set clsLabel = Me.Controls.Add("Forms.Label.1", "LbDay" & i) With clsLabel .Top = iRow * 13 + 30 .Left = iCol * 20 + 1.5 .Width = 20 .Height = 13 .Caption = Day(i) .Font.Size = 11 .Font.Name = "Georgia" .TextAlign = fmTextAlignCenter' .BorderStyle = fmBorderStyleSingle If Month(i) = Month(myDate) Then '设置前景色，如果日期不在本月的，设成灰色 .ForeColor = arrForeColor(iCol) Else .ForeColor = RGB(150, 150, 150) End If If i = Date Then '设置当前日期标签的背景色，今天标色，当前日期标色 .BackColor = RGB(0, 250, 154) ElseIf i = myDate Then .BackColor = RGB(100, 149, 237) Else .BackColor = RGB(255, 250, 205) End If End With clsDC.ReceiveLabel clsLabel co.Add clsDC Set clsDC = Nothing Next lngTitleBarHeight = GetSystemMetrics(4) Me.Height = Controls("LbDay" & datLastDay).Top + Controls("LbDay" & datLastDay).Height + lngTitleBarHeight + 1.5 End Sub3、在ThisWorkbook里，日期控件相关代码，工作簿Open事件：
Option ExplicitPrivate Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _ ByVal lpWindowName As String) As LongPrivate Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As LongPrivate Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As LongPrivate Declare PtrSafe Function MoveWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal x As Long, _ ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As LongPrivate Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As LongPrivate Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As LongPtrPublic preDate As DatePrivate Sub Workbook_Open() dbs = ThisWorkbook.FullName blnUpdateDeliverNumber = TrueEnd SubPrivate Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Dim lHwnd As Long Dim lDC As Long Dim lCaps As Long Dim lngLeft As Long Dim lngTop As Long Dim sngPiexlToPiont As Single Dim lngTitleBarHeight As Long Dim clsDC As New DateControl On Error Resume Next If Target.Address = clsRG.日期.MergeArea.Address Then If clsDC.IsFormActive("Usf_DateSelect") Then Unload Usf_DateSelect End If With Usf_DateSelect If Selection.Value <> "" Then If IsDate(Selection.Value) Then .Caption = Selection.Value .Controls("CmbYear") = Year(Selection) .Controls("CmbMonth") = Month(Selection) preDate = Selection.Value Else .Caption = Date .Controls("CmbYear") = Year(Date) .Controls("CmbMonth") = Month(Date) preDate = Date End If Else If Target.Offset(-1, 0).Value <> "" Then If IsDate(Target.Offset(-1, 0)) Then .Caption = Target.Offset(-1, 0).Value .Controls("CmbYear") = Year(Target.Offset(-1, 0).Value) .Controls("CmbMonth") = Month(Target.Offset(-1, 0).Value) preDate = Target.Offset(-1, 0).Value Else .Caption = Date .Controls("CmbYear") = Year(Date) .Controls("CmbMonth") = Month(Date) preDate = Date End If Else .Caption = Date .Controls("CmbYear") = Year(Date) .Controls("CmbMonth") = Month(Date) preDate = Date End If End If If Format(.Caption, "YYYYMM") < Format(Date, "YYYYMM") Then .BackColor = RGB(139, 69, 19) ElseIf Format(.Caption, "YYYYMM") > Format(Date, "YYYYMM") Then .BackColor = RGB(144, 238, 144) Else .BackColor = RGB(147, 112, 219) End If .Show Const lLogPixelsX = 88 lDC = GetDC(0) lCaps = GetDeviceCaps(lDC, lLogPixelsX) lngTitleBarHeight = GetSystemMetrics(4) ' 4 对应的是 SM_CYCAPTION sngPiexlToPiont = 72 / lCaps * (100 / Application.ActiveWindow.Zoom) lngLeft = CLng(ActiveWindow.PointsToScreenPixelsX(0) + ((Target.Offset(1, 0).Left + Target.Width) / sngPiexlToPiont)) lngTop = CLng(ActiveWindow.PointsToScreenPixelsY(0) + ((Target.Offset(1, 0).Top - lngTitleBarHeight + Target.Height) / sngPiexlToPiont)) Usf_DateSelect.StartUpPosition = 0 lHwnd = FindWindow(vbNullString, Usf_DateSelect.Caption) MoveWindow lHwnd, lngLeft, lngTop, .Width / (72 / lCaps) * 1.09, .Height / (72 / lCaps) * 1.01, True Usf_DateSelect.Show 0 End With Else Unload Usf_DateSelect End If Target.ActivateEnd Sub4、在模块myModule里，自定义函数、过程：
Public clsDQ As New DataQueryPublic clsRG As New clsRangesPublic dbs As StringPublic blnUpdateDeliverNumber As BooleanPublic processType As StringFunction GetExtn(iName) '//取得文件扩展名 GetExtn = Right(iName, Len(iName) - InStrRev(iName, ".") + 1)End FunctionSub updateDeliverNumber() Dim ws As Worksheet Dim DeliverNumber As String Dim strDate As String Dim prefix As String Set ws = ThisWorkbook.Sheets("送货单") With ws strDate = Format(clsRG.日期, "yyyymmdd") DeliverNumber = clsDQ.getMaxDeliverNumber(strDate) prefix = "CK" & strDate If InStr(DeliverNumber, prefix) > 0 Then DeliverNumber = prefix & Format(Val(Right(DeliverNumber, 2)) + 1, "00") Else DeliverNumber = prefix & "01" End If clsRG.送货单号 = DeliverNumber End WithEnd SubSub saveNew() Dim DeliverNumber As String Dim strCnn As String Dim cnn As Object, rs As Object Dim arr(), ws As Worksheet, lastRow As Integer, lastCol As Integer Dim supplier As String, category As String, employee As String Dim warehouse As String, currDate As Date Dim serialNumber As String Dim rng As Range, t As Integer dbs = ThisWorkbook.FullName tbl = "[数据$]" Set ws = ThisWorkbook.Sheets("送货单") With ws DeliverNumber = clsRG.送货单号 '//检查单据号是否存在，如果存在则提示、退出 '//如果数据无误，可修改单号后保存（这种情况一般不会出现） If processType = "新增保存" Then If clsDQ.IsDeliverNumberExists(DeliverNumber) Then MsgBox "已存在单据号！请检查！" Exit Sub End If End If End With '//数据完整性检查，表头字段不为空 If clsRG.日期 = 0 Then MsgBox "日期为空！" Exit Sub ElseIf clsRG.客户名称 = "" Then MsgBox "客户为空！" Exit Sub ElseIf clsRG.送货单号 = "" Then MsgBox "收货单号为空！" Exit Sub End If '//检查单据号与日期是否一致 prefix = "CK" & Format(clsRG.日期, "yyyymmdd") If InStr(DeliverNumber, prefix) = 0 Then MsgBox "单据号有误，请更新单据号后再保存！" Exit Sub End If '//检查流水号 For i = 1 To clsRG.序号.Rows.Count If clsRG.序号.Cells(i, 1) > 0 Then serialNumber = clsRG.送货单号 & Format(clsRG.序号.Cells(i, 1), "00") If clsRG.流水号.Cells(i, 1) <> serialNumber Then If Not wContinue("流水号有误，自动更新？") Then Exit Sub t = 1 Exit For End If End If Next '//根据送货单号号与序号重写流水号 If t = 1 Then For i = 1 To clsRG.序号.Rows.Count If clsRG.序号.Cells(i, 1) > 0 Then clsRG.流水号.Cells(i, 1) = clsRG.送货单号 & Format(clsRG.序号.Cells(i, 1), "00") End If Next End If Set rng = clsRG.数据区域 If processType = "新增保存" Then Set cnn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") strCnn = clsDQ.GetStrCnn(dbs) cnn.Open strCnn With rs .Open tbl, cnn, 1, 3 For i = 1 To rng.Rows.Count If rng.Cells(i, 1) > 0 Then .addNew .Fields("日期") = clsRG.日期 .Fields("送货单号") = clsRG.送货单号 .Fields("客户名称") = clsRG.客户名称 For j = 2 To rng.Columns.Count .Fields(CStr(clsRG.表头.Cells(1, j).Value)) = rng.Cells(i, j) Next .Update End If Next End With ElseIf processType = "更新保存" Then For i = 1 To rng.Rows.Count If rng.Cells(i, 1) > 0 Then serialNumber = clsRG.流水号.Cells(i, 1) sql = "UPDATE [数据$] " & _ "SET 日期 = #" & clsRG.日期 & "#, " & _ "客户名称 = '" & clsRG.客户名称 & "', " & _ "送货单号 = '" & clsRG.送货单号 & "', " & _ "物料名称 = '" & rng.Cells(i, 2) & "', " & _ "规格 = '" & rng.Cells(i, 3) & "', " & _ "加工说明 = '" & rng.Cells(i, 4) & "', " & _ "单位 = '" & rng.Cells(i, 5) & "', " & _ "数量 = '" & rng.Cells(i, 6) & "', " & _ "单价 = '" & rng.Cells(i, 7) & "', " & _ "金额 = '" & rng.Cells(i, 8) & "', " & _ "箱数 = '" & rng.Cells(i, 9) & "', " & _ "备注 = '" & rng.Cells(i, 10) & "' " & _ "WHERE 流水号 = '" & serialNumber & "'" clsDQ.ExecuteSQL (sql) End If Next End If ThisWorkbook.Save Call clsRG.clearData Call updateDeliverNumber MsgBox "保存成功！"End SubSub printWorksheet() Dim ws As Worksheet, lastRow As Integer, lastCol As Integer Dim rng As Range If Not Application.Dialogs(xlDialogPrinterSetup).Show Then Exit Sub Set ws = ThisWorkbook.Sheets("送货单") With ws lastRow = 20 lastCol = 12 Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol)) With .PageSetup .PrintArea = rng.Address .PaperSize = xlPaperA4 .Orientation = xlPortrait .FitToPagesWide = 1 .FitToPagesTall = 1 End With .PrintOut copies:=1 End WithEnd SubFunction IsArrEmpty(ByVal sArray As Variant) As Boolean '//判断数组是否为空 Dim i As Long IsArrEmpty = False On Error GoTo lerr: i = UBound(sArray) Exit Functionlerr: IsArrEmpty = TrueEnd FunctionFunction wContinue(Msg) As Boolean '确认继续函数 Dim Config As Long Dim a As Long Config = vbYesNo + vbQuestion + vbDefaultButton2 Ans = MsgBox(Msg & Chr(10) & Chr(10) & "是(Y)继续?" & Chr(10) & Chr(10) & "否(N)退出！", Config) wContinue = Ans = vbYesEnd Function5、在类模块clsRanges里，定义单元格区域：
Private ws As WorksheetPrivate Sub Class_Initialize() Set ws = ThisWorkbook.Worksheets("送货单")End SubPublic Property Get 日期() As Range Set 日期 = ws.Range("I5")End PropertyPublic Property Get 送货单号() As Range Set 送货单号 = ws.Range("I4")End PropertyPublic Property Get 客户名称() As Range Set 客户名称 = ws.Range("B4")End PropertyPublic Property Get 收货地址() As Range Set 收货地址 = ws.Range("B5")End PropertyPublic Property Get 数量() As Range Set 数量 = ws.Range("F7:F16")End PropertyPublic Property Get 单价() As Range Set 单价 = ws.Range("G7:G16")End PropertyPublic Property Get 数量合计() As Range Set 数量合计 = ws.Range("F17")End PropertyPublic Property Get 金额() As Range Set 金额 = ws.Range("H7:H16")End PropertyPublic Property Get 金额合计() As Range Set 金额合计 = ws.Range("H17")End PropertyPublic Property Get 箱数() As Range Set 箱数 = ws.Range("I7:I16")End PropertyPublic Property Get 箱数合计() As Range Set 箱数合计 = ws.Range("I17")End PropertyPublic Property Get 数据区域() As Range Set 数据区域 = ws.Range("A7:K16")End PropertyPublic Property Get 物料名称() As Range Set 物料名称 = ws.Range("B7:B16")End PropertyPublic Property Get 序号() As Range Set 序号 = ws.Range("A7:A16")End PropertyPublic Property Get 流水号() As Range Set 流水号 = ws.Range("K7:K16")End PropertyPublic Property Get 表头() As Range Set 表头 = ws.Range("A6:K6")End PropertyPublic Sub clearData() 客户名称 = "" 收货地址 = "" 数据区域.ClearContents 数量合计 = 0 金额合计 = 0 箱数合计 = 0 End Sub6、在类模块DataQuery里，数据库处理相关代码：
Dim strCnn As StringDim cnn As Object '数据库连接Dim rs As Object '临时数据表纪录Function GetStrCnn(ByVal DbFile As String, Optional ByVal Psw As String = "") '//获取数据库连接字符串 Dim sType$ sType = GetExtn(DbFile) If InStr(sType, "accdb") Then Select Case Application.Version * 1 '设置连接字符串,根据版本创建连接 Case Is <= 11 GetStrCnn = "Provider=Microsoft.Jet.Oledb.4.0;Jet OLEDB:Database Password=" & Psw & ";Data Source=" & DbFile Case Is >= 12 GetStrCnn = "Provider=Microsoft.ACE.OLEDB.12.0;Jet OLEDB:Database Password=" & Psw & ";Data Source=" & DbFile End Select ElseIf InStr(sType, "xl") Then GetStrCnn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & DbFile End IfEnd FunctionSub ExecuteSQL(sql As String) '//执行SQL语句 On Error Resume Next Set cnn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") dbs = ThisWorkbook.FullName strCnn = GetStrCnn(dbs, Psw) cnn.Open strCnn '打开数据库链接 cnn.Execute (sql) cnn.Close Set cnn = NothingEnd SubFunction RecordValue(sql) '函数名的含义为“记录值”，实际为取到的第一行第一列的值 '通常用来 select count() 来取值，这样，函数的值或为0,或大于0,如果值为0,则表示没有记录 '可以用来判断一个表有没有记录，或者有没有指定字段符合一定条件的记录 On Error Resume Next Dim arr() Set cnn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") On Error Resume Next dbs = ThisWorkbook.FullName strCnn = GetStrCnn(dbs, Psw) cnn.Open strCnn '打开数据库链接 Set rs = cnn.Execute(sql) '执行查询，并将结果输出到记录集对象 arr = rs.getrows RecordValue = arr(0, 0) rs.Close Set rs = Nothing cnn.Close Set cnn = NothingEnd FunctionFunction getData(sql) '//获取查询结果，存到数组' On Error Resume Next Set cnn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") On Error Resume Next dbs = ThisWorkbook.FullName strCnn = GetStrCnn(dbs, Psw) cnn.Open strCnn '打开数据库链接 Set rs = cnn.Execute(sql) '执行查询，并将结果输出到记录集对象 getData = rs.getrows rs.Close Set rs = Nothing cnn.Close Set cnn = NothingEnd FunctionFunction IsDeliverNumberExists(DeliverNumber As String) As Boolean '//判断送货单号是否存在于“数据” Dim tbl As String, sql As String Dim arr() tbl = "[数据$]" sql = "select count(*) from " & tbl & " where 送货单号='" & DeliverNumber & "'" arr = getData(sql) If arr(0, 0) > 0 Then IsDeliverNumberExists = True Else IsDeliverNumberExists = False End IfEnd FunctionFunction getMaxDeliverNumber(strDate As String) As String '//取得当前日期最大的付款单号 On Error Resume Next Dim tbl As String, sql As String Dim arr() tbl = "[数据$]" sql = "select top 1 送货单号 from " & tbl & " where format(日期 ,'yyyymmdd') ='" & strDate & "' order by 送货单号 DESC" arr = getData(sql) getMaxDeliverNumber = arr(0, 0)End FunctionFunction IsSerialNumberExists(serialNumber As String) As Boolean '//判断流水号是否存在于“数据” Dim tbl As String, sql As String Dim arr() tbl = "[数据$]" sql = "select count(*) from " & tbl & " where 流水号='" & serialNumber & "'" arr = getData(sql) If arr(0, 0) > 0 Then IsSerialNumberExists = True Else IsSerialNumberExists = False End IfEnd Function7、在类模块DateControl 里，日期控件相关代码：
Private WithEvents clsLabel As MSForms.LabelPrivate WithEvents clsComboBox As MSForms.ComboBoxPrivate WithEvents clsCommandButton As MSForms.CommandButtonProperty Get myDate() As Date With Usf_DateSelect myDate = CDate(.Caption) End WithEnd PropertyPublic Sub ReceiveLabel(ByVal reLabel As MSForms.Label) Set clsLabel = reLabelEnd SubPublic Sub ReceiveComboBox(ByVal reComboBox As MSForms.ComboBox) Set clsComboBox = reComboBoxEnd SubPublic Sub ReceiveCommandButton(ByVal reCommandButton As MSForms.CommandButton) Set clsCommandButton = reCommandButtonEnd SubPrivate Sub clsComboBox_Change() With Usf_DateSelect .AddLabel_Day DateSerial(.Controls("CmbYear"), .Controls("CmbMonth"), Day(.Caption)) End WithEnd SubPrivate Sub clsCommandButton_Click() Dim currValue As Integer Dim currMonth As String Dim currFirstDay As Date With Usf_DateSelect Select Case clsCommandButton.Name Case "YearDecrease" currValue = .Controls("CmbYear").Value If currValue <> 1900 Then .Controls("CmbYear").Value = currValue - 1 Case "YearIncrease" currValue = .Controls("CmbYear").Value If currValue <> 2999 Then .Controls("CmbYear").Value = currValue + 1 Case "MonthDecrease" currValue = .Controls("CmbMonth").Value .Controls("CmbMonth").Value = IIf(currValue - 1 Mod 12, currValue - 1, 12) Case "MonthIncrease" currValue = .Controls("CmbMonth").Value .Controls("CmbMonth").Value = IIf(currValue Mod 12, currValue + 1, 1) End Select currMonth = .Controls("CmbYear").Value & Format(.Controls("Cmbmonth").Value, "00") currFirstDay = CDate(.Controls("CmbYear").Value & "/" & .Controls("Cmbmonth").Value & "/1") If currMonth <> Format(.Caption, "YYYYMM") Then .AddLabel_Day currFirstDay End If If currMonth < Format(Date, "YYYYMM") Then .BackColor = RGB(139, 69, 19) ElseIf currMonth > Format(Date, "YYYYMM") Then .BackColor = RGB(144, 238, 144) Else .BackColor = RGB(147, 112, 219) End If End WithEnd SubPrivate Sub clsLabel_Click() Selection = Replace(clsLabel.Name, "LbDay", "") Selection.NumberFormatLocal = "yyyy/m/d" Unload Usf_DateSelectEnd SubPrivate Sub clsLabel_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single) clsLabel.BorderStyle = 0 clsLabel.BackColor = RGB(135, 206, 250) End SubFunction IsFormActive(UsfName As String) As Boolean Dim i As Integer For i = 0 To UserForms.Count - 1 IsFormActive = UserForms(i).Name = UsfName If IsFormActive Then Exit Function NextEnd Function。~~~~~~End~~~~~~
本站仅提供存储服务，所有内容均由用户发布，如发现有害或侵权内容，请点击举报。
