等待修改的代码

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]")&"分"))))