基于excle 用vba 编写的简易订单管理

基于excle 用vba 编写的简易订单管理

板式家具生产排版录单
1.主要功能
订单号及其他客户的补全、填写相应列的固定参数、 保存录入的信息到总表、清空录入界面，针对 不同软件填写不同的参数。
2.基本原理
对单元格格式的设置、对数组内的数据的操作等

'表格滚动区域
Private Sub Workbook_Open()
    Worksheets("录单").ScrollArea = "A1:L100"
End Sub

Private Sub CommandButton13_Click()
        '数据弹窗验证
        Dim i As Integer
        lastRow = ActiveSheet.UsedRange.Rows.Count
        For i = 3 To lastRow
            ActiveSheet.Range("H" & i).Select
            result = MsgBox(Cells(i, 5) & "      高度        宽度        数量" & vbCrLf & vbCrLf & "         " & Cells(i, 8) & "        x         " & Cells(i, 9) & "        =        " & Cells(i, 11), vbOKCancel, "对照检验数据")
           If result = vbOK Then
               '用户按下“确认”，执行后续代码
           ElseIf result = vbCancel Then
              '用户按下“取消”，退出程序
              '光标移动至问题数据行
            Range("H" & i & ":K" & i).Interior.color = 255
            Exit For
          End If
          If i = lastRow Then
            MsgBox ("验单完成")
             result = MsgBox("是否保存数据到汇总表", vbOKCancel, "保存数据")
           If result = vbOK Then
               '用户按下“确认”，执行后续代码
               CommandButton6_Click
           ElseIf result = vbCancel Then
              
           End If
          End If
        Next i
End Sub

Private Sub CommandButton2_Click()
    '生成云熙数据
   ' CommandButton6_Click
    lastRow = ActiveSheet.UsedRange.Rows.Count
     For i = 3 To lastRow
            Cells(i, 12).Value = 1
            Cells(i, 13).Value = 1
            Cells(i, 14).Value = 1
            Cells(i, 15).Value = 1
    Next i
    If lastRow >= 3 Then
        Sheets("录单").Range("A3:O" & lastRow).Copy _

        MsgBox "数据已复制"
    Else
        MsgBox "未发现数据，请填写数据"
    End If
    
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    '输入到K列自动换行
    Dim sro, sco, ro, co
    On Error Resume Next                '忽略运行时可能出现的错误
    Application.EnableEvents = False    '开启代码只执行一次
    Set mysheet1 = ThisWorkbook.Worksheets("录单")
    sro = Selection.Row      '选择单元格所在的行
    sco = Selection.Column   '选择单元格所在的列
    If sro > 3 And sco > 7 And sco <= 11 Then  '如果所选的单元格为第二行起，高~数量列之间，则
     ro = Target.Row       '获取改变单元格所在的行
     co = Target.Column    '获取改变单元格所在的列
     If co = 11 Then                    '如果已经到达K列，则
      mysheet1.Cells(ro + 1, 8).Select  '换行，选择下一个单元格
     End If
     If co > 1 And co < 11 Then        '如果只在B-k列，则
      mysheet1.Cells(ro, co + 1).Select '选择右边单元格
     End If
    End If
    Application.EnableEvents = True    '恢复代码只执行一次

End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    '输入数据跳过厚度列 并换行
   Static sRg As Range
    Dim ColumnOffset As Integer
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Union([A:A], [J:J], [L:L])) Is Nothing Then
        With Target
        Application.EnableEvents = False
        If Not sRg Is Nothing Then
            If sRg.Column < .Column Then
                ColumnOffset = 1
            ElseIf .Column <> 1 Then
                ColumnOffset = -1
            End If
        Else
            ColumnOffset = 1
        End If
        .Offset(, ColumnOffset).Select
        Application.EnableEvents = True
        End With
    End If
    Set sRg = ActiveCell
End Sub
Sub DataAdd()
     '数据信息补全
      Dim lngLastRow As Long
      Dim i As Long
      Dim j As Long
      Dim k As Long
      Dim cdat As String
      Dim randomnum
      Randomize ' Initialize random-number generator.
      randomnum = Int((100 * Rnd) + 1)
      cdat = Format(Now(), "yyyymmdd")
       '获取 工作表中已使用区域最后一行的行号
       lngLastRow = ActiveSheet.UsedRange.Rows.Count
       '遍历行
       ' 1、补全单号信息 2、补全客户信息 3、补全厚度 封边信息
       For i = 3 To lngLastRow
            For j = 1 To 12
          '判断每行中第1列的单元格是否为空
             If IsEmpty(Cells(i, j)) Then
             '若为空则设置该行相应单元格
                If j = 1 Then
                    '补全单号信息
                     Cells(i, 1).Value = Format(Now, "yyyy") & Format(Now, "mm") & Format(Now, "dd") & randomnum & "-" & i - 2
                     
                    
                ElseIf j = 12 Then
                     Cells(i, 12).Value = "-1|-1|-1|-1"
                ElseIf j = 10 Then
                    '补全厚度信息
                     Cells(i, 10).Value = 18
                ElseIf j = 2 Then
                    On Error Resume Next
                     ' Look in column A
                    With Columns(2)
                          ' For blank cells, set them to equal the cell above
                            .SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C"
                            'Convert the formula to a value
                         .Value = .Value
                    End With
                    Err.Clear
                ElseIf j = 3 Then
                     On Error Resume Next
                     ' Look in column A
                    With Columns(3)
                          ' For blank cells, set them to equal the cell above
                            .SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C"
                            'Convert the formula to a value
                         .Value = .Value
                    End With
                    Err.Clear
                ElseIf j = 5 Then
                     On Error Resume Next
                     ' Look in column A
                    With Columns(5)
                          ' For blank cells, set them to equal the cell above
                            .SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C"
                            'Convert the formula to a value
                         .Value = .Value
                    End With
                    Err.Clear
               
                End If
            End If
          Next j
          Rows(i).RowHeight = 18
          If (i Mod 2) = 0 Then
            Range("A" & i & ":L" & i).Interior.color = 16247773
            
          Else
             Range("A" & i & ":L" & i).Interior.color = 11854022
          End If
        Next i
End Sub
Private Sub CommandButton12_Click()
    '导出天工数据到剪切板
    lastRow = ActiveSheet.UsedRange.Rows.Count
    If lastRow >= 3 Then
        For i = 3 To lastRow
            Cells(i, 12).Value = "-1|-1|-1|-1"
            Cells(i, 13).Value = ""
            Cells(i, 14).Value = ""
            Cells(i, 15).Value = ""
        Next i
        Sheets("录单").Range("A3:L" & lastRow).Copy _
        
        
        MsgBox "数据已复制"
    Else
        MsgBox "未发现数据，请填写数据"
    End If
End Sub

Private Sub CommandButton14_Click()
    '快速置顶
    Dim lastRow As Long
    Dim currentRow As Long
    '获取当前选中单元格所在行号
     currentRow = ActiveCell.Row
     lastRow = ActiveSheet.UsedRange.Rows.Count
      If currentRow > 20 Then '将焦点移动到最后一行（从第二行开始）
        ActiveSheet.Range("A" & 2).Select
      Else
        If lastRow > 1 Then
           ActiveSheet.Range("A" & lastRow + 1).Select
        End If
        
     End If
End Sub

Private Sub CommandButton6_Click()
    '存储录入数据到总表
    Dim FinalRow As Long
    Dim FinalRow2 As Long
    FinalRow = Sheets("录单").Cells(Rows.Count, 1).End(xlUp).Row
    FinalRow2 = Sheets("订单汇总表").UsedRange.Rows.Count
    
    If IsEmpty(Cells(FinalRow - 1, 1)) Then
            DataAdd
    End If
    Sheets("录单").Select
    Worksheets("录单").Range("A3:M" & FinalRow + 1).Copy
   ' Worksheets("订单汇总表").Activate
    ActiveSheet.Paste Destination:=Worksheets("订单汇总表").Range("A" & FinalRow2 + 1 & ":L" & FinalRow2 + FinalRow)
    MsgBox "数据已保存到汇总表", vbOKOnly, "提示"
End Sub

Private Sub CommandButton7_Click()
    '数据补全按钮
     DataAdd
     MsgBox "单号已填写完成"
End Sub
Private Sub CommandButton8_Click()
    '一键清空数据
    Dim lastRow As Long
    Dim lastCol As Long
    Dim l As Integer
    lastRow = ActiveSheet.UsedRange.Rows.Count
    result = MsgBox("按「确定」清空数据，按「取消」退出", vbOKCancel, "请确认数据已保存")
    If result = vbOK Then
        '用户按下“确认”，执行后续代码
        If lastRow >= 3 Then
            Range("A3:L" & lastRow).ClearContents
            Range("A3:L" & lastRow).Interior.ColorIndex = 0
            For lastRow = lastRow To 3 Step -1
                Rows(lastRow).Delete
             Next
            MsgBox "数据已清空"
        Else
            MsgBox "数据异常手动清空"
        End If
    ElseIf result = vbCancel Then
       '用户按下“取消”，退出程序
    End If
End Sub

汇总表

Private Sub CommandButton1_Click()
    ActiveSheet.Range("$A$1:$L$41500").AutoFilter Field:=1, Criteria1:=T2
     '冻结隔窗
     '  Dim sht As Worksheet
   ' For Each sht In ThisWorkbook.Worksheets
     '   sht.Activate
     ActiveSheet.Cells(2, 1).Select
     With ActiveWindow
            .ScrollRow = 1 '当前窗口最上面的行号，相当于移动最右侧的滚动条
            .SplitColumn = 0 '拆分(冻结)窗口，保留第几列
            .SplitRow = 1 '拆分(冻结)窗口，保留第几行
        End With
        ActiveWindow.FreezePanes = True
   ' Next
End Sub

Private Sub CommandButton2_Click()
    Application.ScreenUpdating = False
    Cells.Rows.Hidden = False
    Application.ScreenUpdating = True
        '取消筛选
    ActiveSheet.AutoFilterMode = False '取消筛选状态
    If ActiveSheet.AutoFilterMode = True Then '判断，并取消筛选状态
        ActiveSheet.AutoFilterMode = False
    End If
    
End Sub

Private Sub CommandButton4_Click()
    Dim lastRow As Long
    Dim targetSheet As Worksheet
    '指定目标工作表，这里为“Sheet1”
    Dim currentRow As Long
    '获取当前选中单元格所在行号
     currentRow = ActiveCell.Row
     lastRow = ActiveSheet.UsedRange.Rows.Count
      If currentRow > 20 Then '将焦点移动到最后一行（从第二行开始）
        ActiveSheet.Range("A" & 2).Select
      Else
        If lastRow > 1 Then
           ActiveSheet.Range("A" & lastRow + 1).Select
        End If
        
     End If
     
End Sub
Private Sub CommandButton3_Click()
    Dim templateSheet As Worksheet
    Dim selectedRange As Range
    Dim dataArray As Range
     Dim i As Integer, j As Integer
    '指定模板工作表，这里为“Template”
    Set templateSheet = ThisWorkbook.Sheets("出货单模板")
    '检查所选区域是否包含完整行
     '获取当前选择的区域
     Worksheets("订单汇总表").Activate
    Set selectedRange = Selection
    rows_count = selectedRange.Rows.Count  '返回选择区域的行数
    column_count = selectedRange.Columns.Count '返回选择区域列数
    If column_count < 12 Then
        MsgBox "您未选择完整行！重新选择数据"
        Exit Sub
     End If
    '检查所选区域第二列客户列是否包含相同数据
        With selectedRange.Columns(2)
            If WorksheetFunction.CountIf(.Cells, .Cells(1)) <> .Rows.Count Then
                MsgBox "请选择同一客户订单！"
                Exit Sub
            End If
        End With
        '将所选区域中的数据赋值给数组变量
        Worksheets("出货单模板").Activate
        MoveSheets
      '  Debug.Print "selectedRange(1, 1)=" & selectedRange(1, 1)
        '以2，3为订单号，以2，7为客户名 2，9为订单时间 截取订单号前八位 3，3终端客户
        '填写尺寸数据.对话框设置单位价格 计算
        Debug.Print selectedRange(1, 5)
        Set DataRange = Range("B7:E" & 6 + rows_count)
        DataRange.ClearContents
  
        With templateSheet
            .Range("C2").Value = selectedRange(1, 1).Value
            .Range("G2").Value = selectedRange(1, 2).Value
            .Range("I2").Value = selectedRange(1, 1).Value
            .Range("C3").Value = selectedRange(1, 3).Value
         End With
         For i = 1 To rows_count '行
                 With templateSheet
                 .Range("B" & 6 + i) = selectedRange(i, 5)
                 .Range("C" & 6 + i) = selectedRange(i, 8)
                 .Range("D" & 6 + i) = selectedRange(i, 9)
                 .Range("E" & 6 + i) = selectedRange(i, 11)
                 .Range("F" & 6 + i) = selectedRange(i, 7)
                End With
          Next i
End Sub

Sub MoveSheets()
    Worksheets("出货单模板").Copy
    With ActiveWorkbook
     .SaveAs Filename:=Environ("TEMP") & "\New1.xlsm", FileFormat:=xlOpenXMLWorkbook
   '  .Close SaveChanges:=False
End With
   
End Sub