工作中发现每次排翻缝计划时，总要把excel总表的订单信息按每个订单预定计划领坯日期，复制到翻缝计划表对应的日期下。今天就琢磨着能否一键搞定，实现自动翻缝排单，没有想到41行代码就能搞定每天要花20分钟的工作量，把过程记录下：
源表一（总表）
目标表二（翻缝计划）
实现思路：
先获取总表中选取行的所有行号并存入数组中，然后把所在行对应的计划领坯日期去翻缝计划中去查找，找到后获得翻缝计划表里
的日期所在的行号，并向下移动3行插入一空白行，再把总表中相应的订单信息数据对应填下到翻缝计划表的空白行中，同时把对应合约号以红色底纹标识。
自动排单按钮后的vba代码：
Public Sub getrows_to_fanbu()
Dim a() As Integer
k = Selection.Cells.Count
ReDim a(k)
a(0) = -1
n = 0
For Each c In Selection.Cells
n = n + 1
a(n) = c.Row
For i = 0 To n - 1
If a(n) = a(i) Then
n = n - 1
End If
Next i
Next c
Application.StatusBar = "系统正在自动排单中，请耐心等待1分钟左右...."
Dim currow As Double
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.MaxChange = 0.001
For i = 1 To n
currow = Application.WorksheetFunction.Match(Sheets("总表").Cells(a(i), 16), Sheets("翻缝计划").Range("k:k"), 1)
Sheets("翻缝计划").Rows(currow + 3).Resize(1).Insert '翻缝日期下第二行处插入一空白行
'翻缝计划表里写入数据
Sheets("翻缝计划").Cells(currow + 3, 1) = Sheets("总表").Cells(a(i), 2)
Sheets("翻缝计划").Cells(currow + 3, 2) = Sheets("总表").Cells(a(i), 3)
Sheets("翻缝计划").Cells(currow + 3, 3) = Sheets("总表").Cells(a(i), 4)
Sheets("翻缝计划").Cells(currow + 3, 4) = Sheets("总表").Cells(a(i), 5)
Sheets("翻缝计划").Cells(currow + 3, 5) = Sheets("总表").Cells(a(i), 6)
Sheets("翻缝计划").Cells(currow + 3, 6) = Sheets("总表").Cells(a(i), 7)
Sheets("翻缝计划").Cells(currow + 3, 7) = Sheets("总表").Cells(a(i), 8)
Sheets("翻缝计划").Cells(currow + 3, 8) = Sheets("总表").Cells(a(i), 9)
Sheets("翻缝计划").Cells(currow + 3, 9) = Sheets("总表").Cells(a(i), 10)
Sheets("翻缝计划").Cells(currow + 3, 10) = Sheets("总表").Cells(a(i), 11)
Sheets("翻缝计划").Cells(currow + 3, 11) = Sheets("总表").Cells(a(i), 12)
Sheets("翻缝计划").Cells(currow + 3, 12) = Sheets("总表").Cells(a(i), 13)
Sheets("翻缝计划").Cells(currow + 3, 13) = Sheets("总表").Cells(a(i), 14)
'格式化填写的数据
Sheets("翻缝计划").Cells(currow + 3, 2).Interior.Color = RGB(255, 0, 0) '设置合约号单元格的背景色为红色
'Sheets("翻缝计划").Activate
'' Sheets("翻缝计划").Range(Cells(currow + 3, 1), Cells(currow + 3, 14)).Select
'With Selection
' .Font.Name = "宋体"
' .Font.Size = 10
' .Font.FontStyle = "常规"
' End With
'MsgBox currow
Next i
Application.Calculation = xlCalculationAutomatic
Application.MaxChange = 0.001
Application.ScreenUpdating = True
Application.StatusBar = "自动排单成功"
' Dim oe As New Excel.Application
' Dim ow As Workbook
' Dim os As Worksheet
' Set ow = oe.Workbooks.Open("E:\其他\外发加工单.xls")
' Set os = ow.Worksheets("加工单")
' oe.Visible = False
'For i = 1 To n
'a(i) 为选定单元格所在的行数
' ' os.Cells(2, 4) = ""
' os.Cells(3, 2) = ""
' os.Cells(4, 2) = ""
' os.Cells(4, 6) = "0 米"
' os.Cells(5, 2) = ""
' os.Cells(2, 4) = Trim(Cells(a(i), 2))
' os.Cells(3, 2) = Trim(Cells(a(i), 3)) & " " & Trim(Cells(a(i), 4)) & " " & Trim(Cells(a(i), 5))
' os.Cells(4, 2) = Trim(Cells(a(i), 6))
' os.Cells(4, 6) = Cells(a(i), 7) & " 米"
' os.Cells(5, 2) = Trim(Cells(a(i), 12))
' os.PrintOut
'Next i
' ow.Save
' ow.Close
' Set ow = Nothing
' oe.Quit
'
End Sub
使用方法：
1、选定总表中需要排单的所在行（可以同时选多行）
2、点击自动排单按钮
编程中遇到的问题：
因为数据量很大，插入空白行-复制--黏贴，excel每次都要自动计算很耗时，操作10行数据基本需要5分钟左右，为了优化问题，vba源码里在操作数据前，先让excel关闭自动刷新屏幕和关闭自动重算功能，当数据填写完毕并格式化好文本后，再次开启自动重算和自动刷新屏幕，这时会发现自动排单时间由原来5分钟变为12秒钟。
|
QQ好友和群
QQ空间
腾讯微博
腾讯朋友
收藏
淘帖
顶
踩
