Public Myr&, Arrsj
Private Sub CommandButton1_Click() '查询
On Error Resume Next '
Dim k
With Sheets("汇总表")
'If [i3] < " " Then MsgBox "请填单据号": Exit Sub
k = MsgBox("温馨提示:按送货单号查询请按[确定]键,按订单编号查询请按[取消]键,请注意单号编号格式。", vbOKCancel, "记录查询")
If k = vbOK Then
Call 按送货单号查询
ElseIf k = vbCancel Then '按下了取消或关闭键"
Call 按订单编号查询
End If
End With
'CommandButton3.Enabled = False
End Sub
Sub 按送货单号查询()
On Error Resume Next '
Dim x
Dim h
Dim ar
Dim rg1
With Sheets("汇总表")
x = InputBox("按送货单号查询,请输入送货单号。 ")
If x <> "" Then
[b3,b4,i3,i4,a6:h13,j6:j13] = ""
Set rg1 = .[c:c].Find(x, , , 1)
If rg1 Is Nothing Then MsgBox "没找到 " & x & " 送货单号": Exit Sub
[b3] = rg1(1, -1)
[b4] = rg1(1, 0)
[i3] = rg1(1, 1)
[i4] = rg1(1, 2)
For h = 6 To 13
If rg1 = x Then
ar = rg1(1, 1).Offset(, 2).Resize(1, 8)
Cells(h, 1).Resize(1, 8) = ar
Set rg1 = rg1(2, 1)
End If
Next h
ElseIf StrPtr(x) = 0 Then: Exit Sub '按下了取消或关闭键"
End If
End With
Set rg1 = Nothing
End Sub
Sub 按订单编号查询()
On Error Resume Next '
Dim y
Dim arr, i&, m&
Dim rg2
y = InputBox("按订单编号查询,请输入订单编号。 ")
If y <> "" Then
With Sheets("汇总表")
Sheets("按订单查询结果").[a3:n100] = "" '.ClearContents
Set rg2 = .[e:e].Find(y, , , 1) '.Find(y, lookat:=xlWhole)
If rg2 Is Nothing Then MsgBox "没找到 " & y & " 订单编号": Exit Sub
m = 2
arr = .[a1].CurrentRegion
For i = 2 To UBound(arr)
If arr(i, 5) = y Then
m = m + 1
Sheets("按订单查询结果").Cells(m, 1).Resize(1, UBound(arr, 2)) = Application.Index(arr, i, 0)
End If
Next
Sheets("按订单查询结果").Activate
End With
ElseIf StrPtr(x) = 0 Then: Exit Sub '按下了取消或关闭键"
End If
Set rg2 = Nothing
End Sub
Private Sub CommandButton2_Click() '新单
On Error Resume Next '
Set rg = Sheets("汇总表").[c65536].End(3)
[i3] = getNewNum(Trim(CStr([i3].Value)))
[i4] = Date
[b3,b4,a6:h13,j6:j13] = ""
CommandButton3.Enabled = True
End Sub
Private Sub CommandButton3_Click() '存储
On Error Resume Next
Dim w
If [i3].Value < " " Then MsgBox "请填写送货单号及数据": Exit Sub
If Sheets("汇总表").AutoFilterMode = True Then Sheets("汇总表").AutoFilterMode = False
With Sheets("汇总表")
Set rg = .[c:c].Find([i3], , , 1)
If rg Is Nothing Then
Call save
ThisWorkbook.Sheets("送货单").Range("I3").Value = ""
Call CommandButton2_Click
MsgBox "送货单已保存,请确认。"
' Sheets("汇总表").Activate
Else '如果单号重复
w = MsgBox("注意, 送货单号已存在! 继续保存将删除之前的数据并按本单数据据重新录入!" & Chr(13) & "按[确定]继续保存,按[取消]退出。", vbOKCancel, "警告")
If w = vbOK Then
For i = .[365536].End(xlUp).Row To 2 Step -1
.[c:c].Replace [i3].Value, "", 1
.[c:c].SpecialCells(4).EntireRow.Delete
'Sub find_delete()
'VA = [i3].Value
'Application.ScreenUpdating = False
' With [b:b]
' .Replace What:=VA, Replacement:="=1/0", LookAt:=xlWhole, SearchOrder:=xlByRows
' .SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
' End With
' Application.ScreenUpdating = True
'End Sub
Next
Call save
ThisWorkbook.Sheets("送货单").Range("I3").Value = ""
Call CommandButton2_Click
MsgBox "送货单已保存,请确认。"
' Sheets("汇总表").Activate
ElseIf w = vbCancel Then: Exit Sub
End If
End If
End With
End Sub
Sub save()
Dim r, h
Dim ar
With Sheets("汇总表")
r = .[c65536].End(3).Row + 1
For h = 6 To 13
If Cells(h, 3) > " " Then
.Cells(r, 1) = [b3]
.Cells(r, 2) = [b4]
.Cells(r, 3) = [i3]
.Cells(r, 4) = [i4]
ar = Cells(h, 1).Resize(1, 10)
.Range("e" & r & ":n" & r) = ar
r = r + 1
End If
Next h
End With
End Sub
Private Sub CommandButton4_Click() '打印
On Error Resume Next
'ActiveSheet.PrintOut
[a1:j21].PrintOut
End Sub
Sub abc()
'[c14] = Replace([c14], "Z18", "i14")
End Sub
Private Function getNewNum(yuanNum As String) As String
Dim dangRi As String
dangRi = CStr(Format(Date, "yyyymmdd"))
Dim xinNum As String
xinNum = "001"
Dim qianStr As String
Dim isChaXun As Integer
Dim jiNum As String
Dim jiRi As String
qianStr = Trim(CStr(ThisWorkbook.Sheets("SysInfo").Range("B5").Value))
jiNum = Trim(CStr(ThisWorkbook.Sheets("SysInfo").Range("B1").Value))
isChaXun = Val(ThisWorkbook.Sheets("SysInfo").Range("C1").Value)
jiRi = Trim(CStr(ThisWorkbook.Sheets("SysInfo").Range("B3").Value))
If dangRi = jiRi Then
If (Right(yuanNum, 3) <> jiNum) And (isChaXun < 1) Then
xinNum = CStr(Format(Val(jiNum) + 1, "000"))
Else
xinNum = jiNum
End If
End If
ThisWorkbook.Sheets("SysInfo").Range("B1").Value = xinNum
ThisWorkbook.Sheets("SysInfo").Range("B3").Value = dangRi
getNewNum = qianStr & dangRi & xinNum
End Function
'模糊录入
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
On Error Resume Next '
ActiveCell.Offset(, -1).Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 0)
ActiveCell.Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 1)
ActiveCell.Offset(, 1).Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 2)
ActiveCell.Offset(, 2).Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 3)
ActiveCell.Offset(, 3).Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 4)
ActiveCell.Offset(, 5).Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 5)
Me.ListBox1.Clear
Me.TextBox1 = ""
Me.ListBox1.Visible = False
Me.TextBox1.Visible = False
ActiveCell.Offset(1, 0).Select
End Sub
Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
On Error Resume Next '
Dim i As Integer, j%
Dim Language As Boolean, Arr1 As Variant, arr2 As Variant
Dim myStr As String, str_B As String
Me.ListBox1.Clear
With Me.TextBox1
For i = 1 To Len(.Value)
If Asc(Mid$(.Value, i, 1)) > 255 Or Asc(Mid$(.Value, i, 1)) < 0 Then
Language = True
myStr = myStr & Mid$(.Value, i, 1)
Else
myStr = myStr & UCase(Mid$(.Value, i, 1))
End If
Next
End With
ReDim Arr1(0 To UBound(Arrsj), 1 To 6)
If KeyCode = 13 Then ActiveCell = TextBox1.Text: GoTo 100
With Sheet5
arr2 = Array("产品编码", "产品名称", "规格型号", "颜色", "单位", "单价")
'j = j + 1
Arr1(0, 1) = arr2(0)
Arr1(0, 2) = arr2(1)
Arr1(0, 3) = arr2(2)
Arr1(0, 4) = arr2(3)
Arr1(0, 5) = arr2(4)
Arr1(0, 6) = arr2(5)
For i = 1 To UBound(Arrsj)
If InStr(Arrsj(i, 1) & Arrsj(i, 2), myStr) Then
j = j + 1
Arr1(j, 1) = Arrsj(i, 1)
Arr1(j, 2) = Arrsj(i, 2)
Arr1(j, 3) = Arrsj(i, 4)
Arr1(j, 4) = Arrsj(i, 5)
Arr1(j, 5) = Arrsj(i, 7)
Arr1(j, 6) = Arrsj(i, 6)
End If
Next i
With Me.ListBox1
.Clear
.List = Arr1
End With
End With
Exit Sub
100:
Me.ListBox1.Clear
Me.TextBox1 = ""
Me.ListBox1.Visible = False
Me.TextBox1.Visible = False
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next '
' Dim i As Integer
With Sheets("成品编码")
Myr = .[d65536].End(xlUp).Row
Arrsj = .Range("c4:j" & Myr)
End With
If Target.Count = 1 Then
If Target.Column = 3 And Target.Row > 5 And Target.Row < 14 Then
With Me.TextBox1
.Visible = True
.Top = Target.Top
.Left = Target.Left
.Width = Target.Width
.Height = Target.Height * 1.1
.Activate
End With
With Me.ListBox1
.Visible = True
.ColumnCount = 6
.Top = Target.Top
.Left = Target.Left + Target.Width
.Width = Target.Width * 3 '宽度
.Height = Target.Height * 7 '高度
End With
Else
Me.ListBox1.Clear
Me.TextBox1 = ""
Me.ListBox1.Visible = False
Me.TextBox1.Visible = False
End If
If Target.Address() = "$I$4" Then '
Target.Value = Date
End If
End If
Dim i As Integer, j%
Dim Language As Boolean, Arr1 As Variant, arr2 As Variant
Dim myStr As String, str_B As String
Me.ListBox1.Clear
With Me.TextBox1
For i = 1 To Len(.Value)
If Asc(Mid$(.Value, i, 1)) > 255 Or Asc(Mid$(.Value, i, 1)) < 0 Then
Language = True
myStr = myStr & Mid$(.Value, i, 1)
Else
myStr = myStr & UCase(Mid$(.Value, i, 1))
End If
Next
End With
ReDim Arr1(0 To UBound(Arrsj), 1 To 6)
If KeyCode = 13 Then ActiveCell = TextBox1.Text: GoTo 100
With Sheet5
arr2 = Array("产品编码", "产品名称", "规格型号", "颜色", "单位", "单价")
'j = j + 1
Arr1(0, 1) = arr2(0)
Arr1(0, 2) = arr2(1)
Arr1(0, 3) = arr2(2)
Arr1(0, 4) = arr2(3)
Arr1(0, 5) = arr2(4)
Arr1(0, 6) = arr2(5)
For i = 1 To UBound(Arrsj)
' If InStr(Arrsj(i, 1) & Arrsj(i, 2), myStr) Then
j = j + 1
Arr1(j, 1) = Arrsj(i, 1)
Arr1(j, 2) = Arrsj(i, 2)
Arr1(j, 3) = Arrsj(i, 4)
Arr1(j, 4) = Arrsj(i, 5)
Arr1(j, 5) = Arrsj(i, 7)
Arr1(j, 6) = Arrsj(i, 6)
' End If
Next i
With Me.ListBox1
.Clear
.List = Arr1
End With
End With
Cancel = True
TextBox1.Activate
Exit Sub
100:
Me.ListBox1.Clear
Me.TextBox1 = ""
Me.ListBox1.Visible = False
Me.TextBox1.Visible = False
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim khr
If Target.Address() = "$B$3" Then '
With Sheets("客户资料")
r = .[c65536].End(xlUp).Row
khr = .Range("b2:j" & r)
End With
For i = 1 To UBound(khr)
If khr(i, 2) = Range("B3").Value Then
Range("B4") = ""
Range("B4") = khr(i, 4)
End If
Next
End If
CommandButton3.Enabled = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Me.ListBox1.Clear
Me.TextBox1 = ""
Me.ListBox1.Visible = False
Me.TextBox1.Visible = False
End Sub
'---------------------------------------------------------------
'小写转金额大写
'Private Sub Worksheet_Change(ByVal Target As Range)
'If Target.Address()<> "$I$14" Then Exit Sub
'On Error Resume Next
'y = Int(Round(100 * Abs(Target)) / 100)
'j = Round(100 * Abs(Target) + 0.00001) - y * 100
'f = (j / 10 - Int(j / 10)) * 10
'A = IIf(y < 1, "", Application.Text(y, "[DBNum2]") & "元")
'b = IIf(j > 9.5, Application.Text(Int(j / 10), "[DBNum2]") & "角", IIf(y < 1, "", IIf(f > 1, "零", "")))
'c = IIf(f < 1, "整", Application.Text(Round(f, 0), "[DBNum2]") & "分")
'Target.Offset(-6, 0) = IIf(Abs(Target) < 0.005, "", IIf(Target < 0, "负" & A & b & c, A & b & c))
'End Sub
'=IF(I14=0,"",IF(INT(I14)>0,NUMBERSTRING(INT(I14),2)&"元","")&IF(I14=INT(I14),"整"))
'=SUBSTITUTE(SUBSTITUTE(IF(-RMB(I14,2),IF(I14>0,,"负")&TEXT(INT(ABS(I14)+0.5%),"[dbnum2]G/通用格式元;;")&TEXT(RIGHT(RMB(I14,2),2),"[dbnum2]0角0分;;整"),),"零角",IF(I14^2<1,,"零")),"零分","整")
'=" "&IF(F13=0,"",(IF(F13<0,"负","")&(IF(TRUNC(F13)=0,"",(IF(AND(ISERR(FIND("拾万零",TEXT(TRUNC(F13),"[dbnum2]"))),ISERR(FIND("拾万元",TEXT(TRUNC(F13),"[dbnum2]")&"元"))),SUBSTITUTE(TEXT(TRUNC(ABS(F13)),"[DBNum2]"),"拾万","拾万零")&"元",TEXT(TRUNC(ABS(F13)),"[dbnum2]")&"元")))&IF(TRUNC(F13*10)-TRUNC(F13)*10=0,IF(TRUNC(F13)*(TRUNC(F13*100)-TRUNC(F13*10)*10)=0,"","零"),IF(AND((TRUNC(ABS(F13))-TRUNC(ABS(F13)/10)*10)=0,TRUNC(ABS(F13))>0),"零"&TEXT(TRUNC(ABS(F13)*10)-TRUNC(ABS(F13))*10,"[dbnum2]")&"角",TEXT(TRUNC(ABS(F13)*10)-TRUNC(ABS(F13))*10,"[dbnum2]")&"角"))&IF((TRUNC(F13*100)-TRUNC(F13*10)*10)=0,"整",TEXT(TRUNC(ABS(F13)*100)-TRUNC(ABS(F13)*10)*10,"[dbnum2]")&"分"))))