Update VBA modules and test formatting
- Fix test result indicators encoding (use ?? instead of Unicode symbols) - Add missing newlines at end of files - Add new VBA module files for main functionality Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
Misaka_Company
599
VBA/Modules/Module_Main.bas
Normal file
599
VBA/Modules/Module_Main.bas
Normal file
@@ -0,0 +1,599 @@
|
||||
'=============================================================================
|
||||
' 模块：货期检查主模块
|
||||
' 功能：从[生产订单明细查询]提取数据到[货期检查]，并完成货期分析计算
|
||||
'=============================================================================
|
||||
Option Explicit
|
||||
|
||||
'-----------------------------------------------------------------------------
|
||||
' 主入口函数
|
||||
' 功能：协调各子模块完成完整的货期检查流程
|
||||
'-----------------------------------------------------------------------------
|
||||
Public Sub RunDeliveryCheck()
|
||||
Application.ScreenUpdating = False
|
||||
Application.Calculation = xlCalculationManual
|
||||
|
||||
On Error GoTo ErrorHandler
|
||||
|
||||
' 1. 提取生产订单数据到货期检查表
|
||||
Call ExtractOrderData
|
||||
|
||||
' 2. 调用分类器填充产品分类
|
||||
Call FillProductClassification
|
||||
|
||||
' 3. 计算货期相关字段
|
||||
Call CalculateDeliveryFields
|
||||
|
||||
' 4. 自动推算修正交货日期
|
||||
Call AutoCalculateRevisedDate
|
||||
|
||||
Application.Calculation = xlCalculationAutomatic
|
||||
Application.ScreenUpdating = True
|
||||
MsgBox "货期检查完成！", vbInformation
|
||||
|
||||
Exit Sub
|
||||
|
||||
ErrorHandler:
|
||||
Application.Calculation = xlCalculationAutomatic
|
||||
Application.ScreenUpdating = True
|
||||
MsgBox "运行出错：" & Err.Description, vbCritical
|
||||
End Sub
|
||||
|
||||
'-----------------------------------------------------------------------------
|
||||
' 子模块1：从同目录下的[生产订单明细查询.xlsx]提取数据到[货期检查]第4行起
|
||||
' 提取字段：销售合同号,排产号,序号,产品名称,技术参数,型号,业务员,数量,签订日期,交货日期
|
||||
' 注：第11列为“修正交货日期”，留空由用户填写
|
||||
'-----------------------------------------------------------------------------
|
||||
Private Sub ExtractOrderData()
|
||||
Dim srcFilePath As String ' 源文件路径
|
||||
Dim wbSrc As Workbook ' 源工作簿
|
||||
Dim wsSrc As Worksheet ' 源工作表
|
||||
Dim wsDst As Worksheet ' 目标工作表
|
||||
Dim srcData As Variant ' 源数据数组
|
||||
Dim dstData As Variant ' 目标写入数组
|
||||
Dim colMap(1 To 10) As Long ' ★ 目标10个字段在源表中的列索引
|
||||
|
||||
' ★ 目标字段名（前10列，增加销售合同号放在第1列）
|
||||
Dim targetFields(1 To 10) As String
|
||||
targetFields(1) = "销售合同号"
|
||||
targetFields(2) = "排产号"
|
||||
targetFields(3) = "序号"
|
||||
targetFields(4) = "产品名称"
|
||||
targetFields(5) = "技术参数"
|
||||
targetFields(6) = "型号"
|
||||
targetFields(7) = "业务员"
|
||||
targetFields(8) = "数量"
|
||||
targetFields(9) = "签订日期"
|
||||
targetFields(10) = "交货日期"
|
||||
|
||||
srcFilePath = ThisWorkbook.Path & "\生产订单明细查询.xlsx"
|
||||
|
||||
If Dir(srcFilePath) = "" Then
|
||||
MsgBox "找不到数据源文件，请检查该文件是否与当前表格在同一目录下：" & vbCrLf & srcFilePath, vbCritical
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Set wsDst = ThisWorkbook.Worksheets("货期检查")
|
||||
Set wbSrc = Workbooks.Open(Filename:=srcFilePath, ReadOnly:=True)
|
||||
|
||||
On Error Resume Next
|
||||
Set wsSrc = wbSrc.Worksheets("生产订单明细查询")
|
||||
On Error GoTo 0
|
||||
|
||||
If wsSrc Is Nothing Then
|
||||
MsgBox "在源文件中找不到工作表 [生产订单明细查询]！", vbCritical
|
||||
wbSrc.Close SaveChanges:=False
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Dim srcLastRow As Long
|
||||
Dim srcLastCol As Long
|
||||
srcLastRow = wsSrc.Cells(wsSrc.Rows.count, 1).End(xlUp).Row
|
||||
srcLastCol = wsSrc.Cells(1, wsSrc.Columns.count).End(xlToLeft).Column
|
||||
|
||||
If srcLastRow < 2 Then
|
||||
MsgBox "[生产订单明细查询.xlsx] 中无数据行！", vbExclamation
|
||||
wbSrc.Close SaveChanges:=False
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
srcData = wsSrc.Range(wsSrc.Cells(1, 1), wsSrc.Cells(srcLastRow, srcLastCol)).Value
|
||||
wbSrc.Close SaveChanges:=False
|
||||
|
||||
Dim i As Long, j As Long
|
||||
For i = 1 To 10
|
||||
colMap(i) = 0
|
||||
For j = 1 To srcLastCol
|
||||
If Trim(CStr(srcData(1, j))) = targetFields(i) Then
|
||||
colMap(i) = j
|
||||
Exit For
|
||||
End If
|
||||
Next j
|
||||
If colMap(i) = 0 Then
|
||||
MsgBox "源表中找不到字段：" & targetFields(i), vbCritical
|
||||
Exit Sub
|
||||
End If
|
||||
Next i
|
||||
|
||||
Dim dstLastRow As Long
|
||||
dstLastRow = wsDst.Cells(wsDst.Rows.count, 1).End(xlUp).Row
|
||||
If dstLastRow >= 4 Then
|
||||
wsDst.Rows("4:" & dstLastRow).ClearContents
|
||||
End If
|
||||
|
||||
Dim dataRowCount As Long
|
||||
dataRowCount = srcLastRow - 1
|
||||
|
||||
' ★ 目标表总列数变为17列
|
||||
ReDim dstData(1 To dataRowCount, 1 To 17)
|
||||
|
||||
Dim r As Long
|
||||
For r = 1 To dataRowCount
|
||||
Dim srcRow As Long
|
||||
srcRow = r + 1
|
||||
|
||||
' 写入前10个提取字段
|
||||
For i = 1 To 10
|
||||
dstData(r, i) = srcData(srcRow, colMap(i))
|
||||
Next i
|
||||
Next r
|
||||
|
||||
' 写入数据并取消自动换行
|
||||
wsDst.Range(wsDst.Cells(4, 1), wsDst.Cells(3 + dataRowCount, 17)).Value = dstData
|
||||
With wsDst.Range(wsDst.Cells(4, 1), wsDst.Cells(3 + dataRowCount, 17))
|
||||
.WrapText = False
|
||||
.Rows.AutoFit
|
||||
End With
|
||||
End Sub
|
||||
|
||||
'-----------------------------------------------------------------------------
|
||||
' 子模块2：调用GaugeClassifier对[货期检查]的"型号"列进行分类
|
||||
' 结果写入"产品分类"列（现为第12列）
|
||||
'-----------------------------------------------------------------------------
|
||||
Private Sub FillProductClassification()
|
||||
Dim ws As Worksheet
|
||||
Set ws = ThisWorkbook.Worksheets("货期检查")
|
||||
|
||||
Dim lastRow As Long
|
||||
lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
|
||||
|
||||
If lastRow < 4 Then Exit Sub
|
||||
|
||||
' ★ 读取型号列（插入字段后现为第6列）
|
||||
Dim modelArr As Variant
|
||||
modelArr = ws.Range(ws.Cells(4, 6), ws.Cells(lastRow, 6)).Value
|
||||
|
||||
Dim rowCount As Long
|
||||
rowCount = lastRow - 3
|
||||
|
||||
Dim classArr() As Variant
|
||||
ReDim classArr(1 To rowCount, 1 To 1)
|
||||
|
||||
Dim classifier As New GaugeClassifier
|
||||
|
||||
Dim r As Long
|
||||
For r = 1 To rowCount
|
||||
classArr(r, 1) = classifier.Classify(CStr(modelArr(r, 1)))
|
||||
Next r
|
||||
|
||||
' ★ 写入产品分类列（现为第12列）
|
||||
ws.Range(ws.Cells(4, 12), ws.Cells(lastRow, 12)).Value = classArr
|
||||
End Sub
|
||||
|
||||
'-----------------------------------------------------------------------------
|
||||
' 子模块3：计算所有货期相关字段
|
||||
' 第13列 BIP货期（日历天）
|
||||
' 第14列 BIP货期（工作日）
|
||||
' 第15列 工厂货期（工作日）
|
||||
' 第16列 BIP货期是否合理
|
||||
' 第17列 差值
|
||||
'-----------------------------------------------------------------------------
|
||||
Private Sub CalculateDeliveryFields()
|
||||
Dim ws As Worksheet
|
||||
Set ws = ThisWorkbook.Worksheets("货期检查")
|
||||
|
||||
Dim lastRow As Long
|
||||
lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
|
||||
If lastRow < 4 Then Exit Sub
|
||||
|
||||
Dim rowCount As Long
|
||||
rowCount = lastRow - 3
|
||||
|
||||
Dim signDateArr As Variant ' 签订日期 (第9列)
|
||||
Dim delivDateArr As Variant ' 交货日期 (第10列)
|
||||
Dim classArr As Variant ' 产品分类 (第12列)
|
||||
Dim qtyArr As Variant ' 数量 (第8列)
|
||||
|
||||
' ★ 修正读取数据的列索引
|
||||
signDateArr = ws.Range(ws.Cells(4, 9), ws.Cells(lastRow, 9)).Value
|
||||
delivDateArr = ws.Range(ws.Cells(4, 10), ws.Cells(lastRow, 10)).Value
|
||||
classArr = ws.Range(ws.Cells(4, 12), ws.Cells(lastRow, 12)).Value
|
||||
qtyArr = ws.Range(ws.Cells(4, 8), ws.Cells(lastRow, 8)).Value
|
||||
|
||||
Dim holidays As Object
|
||||
Set holidays = LoadHolidays()
|
||||
|
||||
Dim factoryLeadTable As Variant
|
||||
Dim factoryCategories() As String
|
||||
Dim factoryRanges() As String
|
||||
Call LoadFactoryLeadTable(factoryLeadTable, factoryCategories, factoryRanges)
|
||||
|
||||
Dim outArr() As Variant
|
||||
ReDim outArr(1 To rowCount, 1 To 5)
|
||||
|
||||
Dim r As Long
|
||||
For r = 1 To rowCount
|
||||
Dim signDate As Date
|
||||
Dim delivDate As Date
|
||||
Dim category As String
|
||||
Dim qty As Long
|
||||
Dim bipCalendar As Long
|
||||
Dim bipWorkday As Long
|
||||
Dim factoryWD As Long
|
||||
|
||||
If IsEmpty(signDateArr(r, 1)) Or IsEmpty(delivDateArr(r, 1)) Then
|
||||
GoTo NextRow
|
||||
End If
|
||||
|
||||
signDate = CDate(signDateArr(r, 1))
|
||||
delivDate = CDate(delivDateArr(r, 1))
|
||||
category = CStr(classArr(r, 1))
|
||||
qty = CLng(qtyArr(r, 1))
|
||||
|
||||
bipCalendar = DateDiff("d", signDate, delivDate)
|
||||
bipWorkday = CalcWorkdays(signDate, delivDate, holidays)
|
||||
factoryWD = LookupFactoryLead(category, qty, factoryLeadTable, factoryCategories, factoryRanges)
|
||||
|
||||
Dim isReasonable As String
|
||||
If factoryWD <= bipWorkday Then
|
||||
isReasonable = "合理"
|
||||
Else
|
||||
isReasonable = "不合理"
|
||||
End If
|
||||
|
||||
Dim diff As Long
|
||||
diff = bipWorkday - factoryWD
|
||||
|
||||
outArr(r, 1) = bipCalendar
|
||||
outArr(r, 2) = bipWorkday
|
||||
outArr(r, 3) = factoryWD
|
||||
outArr(r, 4) = isReasonable
|
||||
outArr(r, 5) = diff
|
||||
|
||||
NextRow:
|
||||
Next r
|
||||
|
||||
' ★ 一次性写入第13-17列
|
||||
ws.Range(ws.Cells(4, 13), ws.Cells(lastRow, 17)).Value = outArr
|
||||
End Sub
|
||||
|
||||
'-----------------------------------------------------------------------------
|
||||
' 子模块4：自动推算修正交货日期（按排产号统一计算）
|
||||
'-----------------------------------------------------------------------------
|
||||
Private Sub AutoCalculateRevisedDate()
|
||||
Dim ws As Worksheet
|
||||
Set ws = ThisWorkbook.Worksheets("货期检查")
|
||||
|
||||
Dim lastRow As Long
|
||||
lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
|
||||
If lastRow < 4 Then Exit Sub
|
||||
|
||||
Dim rowCount As Long
|
||||
rowCount = lastRow - 3
|
||||
|
||||
Const N As Long = -3
|
||||
|
||||
Dim holidays As Object
|
||||
Set holidays = LoadHolidays()
|
||||
|
||||
' ★ 读取所需列：排产号(2), 签订日期(9), 工厂货期_工作日(15), 差值(17)
|
||||
Dim pcNoArr As Variant, signDateArr As Variant, factoryWdArr As Variant, diffArr As Variant
|
||||
pcNoArr = ws.Range(ws.Cells(4, 2), ws.Cells(lastRow, 2)).Value
|
||||
signDateArr = ws.Range(ws.Cells(4, 9), ws.Cells(lastRow, 9)).Value
|
||||
factoryWdArr = ws.Range(ws.Cells(4, 15), ws.Cells(lastRow, 15)).Value
|
||||
diffArr = ws.Range(ws.Cells(4, 17), ws.Cells(lastRow, 17)).Value
|
||||
|
||||
Dim dictNeedRevise As Object
|
||||
Dim dictMaxDate As Object
|
||||
Set dictNeedRevise = CreateObject("Scripting.Dictionary")
|
||||
Set dictMaxDate = CreateObject("Scripting.Dictionary")
|
||||
|
||||
Dim r As Long
|
||||
Dim pcNo As String
|
||||
|
||||
For r = 1 To rowCount
|
||||
pcNo = Trim(CStr(pcNoArr(r, 1)))
|
||||
If pcNo <> "" Then
|
||||
If Not dictNeedRevise.Exists(pcNo) Then
|
||||
dictNeedRevise.Add pcNo, False
|
||||
dictMaxDate.Add pcNo, CDate(0)
|
||||
End If
|
||||
|
||||
If IsNumeric(diffArr(r, 1)) And Not IsEmpty(diffArr(r, 1)) Then
|
||||
If CLng(diffArr(r, 1)) <= N Then
|
||||
dictNeedRevise(pcNo) = True
|
||||
End If
|
||||
End If
|
||||
|
||||
If IsDate(signDateArr(r, 1)) And IsNumeric(factoryWdArr(r, 1)) Then
|
||||
Dim signDate As Date
|
||||
Dim factoryWD As Long
|
||||
Dim reqDate As Date
|
||||
|
||||
signDate = CDate(signDateArr(r, 1))
|
||||
factoryWD = CLng(factoryWdArr(r, 1))
|
||||
reqDate = AddWorkdays(signDate, factoryWD, holidays)
|
||||
|
||||
If reqDate > dictMaxDate(pcNo) Then
|
||||
dictMaxDate(pcNo) = reqDate
|
||||
End If
|
||||
End If
|
||||
End If
|
||||
Next r
|
||||
|
||||
Dim outArr() As Variant
|
||||
ReDim outArr(1 To rowCount, 1 To 1)
|
||||
|
||||
For r = 1 To rowCount
|
||||
pcNo = Trim(CStr(pcNoArr(r, 1)))
|
||||
If pcNo <> "" Then
|
||||
If dictNeedRevise(pcNo) = True Then
|
||||
If dictMaxDate(pcNo) > CDate(0) Then
|
||||
outArr(r, 1) = dictMaxDate(pcNo)
|
||||
Else
|
||||
outArr(r, 1) = Empty
|
||||
End If
|
||||
Else
|
||||
outArr(r, 1) = Empty
|
||||
End If
|
||||
Else
|
||||
outArr(r, 1) = Empty
|
||||
End If
|
||||
Next r
|
||||
|
||||
' ★ 一次性写入第11列（修正交货日期）
|
||||
ws.Range(ws.Cells(4, 11), ws.Cells(lastRow, 11)).Value = outArr
|
||||
End Sub
|
||||
|
||||
'-----------------------------------------------------------------------------
|
||||
' 日期推算函数：在起始日期基础上往后加上指定的工作日数（自动跳过节假日）
|
||||
'-----------------------------------------------------------------------------
|
||||
Private Function AddWorkdays(startDate As Date, workDaysToAdd As Long, holidays As Object) As Date
|
||||
Dim currentDate As Date
|
||||
Dim addedDays As Long
|
||||
|
||||
currentDate = startDate
|
||||
addedDays = 0
|
||||
|
||||
' 循环递增日期，直到累加的有效工作日达到工厂需要的天数
|
||||
While addedDays < workDaysToAdd
|
||||
currentDate = currentDate + 1
|
||||
Dim dk As Long
|
||||
dk = CLng(currentDate)
|
||||
|
||||
' 如果字典(日历表)中找不到这一天，说明不是休息日，计为一个工作日
|
||||
If Not holidays.Exists(dk) Then
|
||||
addedDays = addedDays + 1
|
||||
End If
|
||||
Wend
|
||||
|
||||
AddWorkdays = currentDate
|
||||
End Function
|
||||
|
||||
'=============================================================================
|
||||
' 辅助函数区
|
||||
'=============================================================================
|
||||
|
||||
'-----------------------------------------------------------------------------
|
||||
' 从[日历]工作表加载节假日（是否休息=1/TRUE/"是"等）到Dictionary
|
||||
' 返回：key=日期序列号(Long)，value=True
|
||||
'-----------------------------------------------------------------------------
|
||||
Private Function LoadHolidays() As Object
|
||||
Dim ws As Worksheet
|
||||
' ★ 修复：Worksheet 对象赋值必须使用 Set
|
||||
Set ws = ThisWorkbook.Worksheets("日历")
|
||||
|
||||
Dim lastRow As Long
|
||||
lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
|
||||
|
||||
Dim dict As Object
|
||||
' ★ 修复：CreateObject 返回对象，赋值必须使用 Set
|
||||
Set dict = CreateObject("Scripting.Dictionary")
|
||||
|
||||
If lastRow < 2 Then
|
||||
Set LoadHolidays = dict
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
' 读取全部数据（含表头）
|
||||
Dim data As Variant
|
||||
data = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, 2)).Value
|
||||
|
||||
' 找日期列和是否休息列
|
||||
Dim dateCol As Long, restCol As Long
|
||||
Dim c As Long
|
||||
For c = 1 To 2
|
||||
Select Case Trim(CStr(data(1, c)))
|
||||
Case "日期": dateCol = c
|
||||
Case "是否休息": restCol = c
|
||||
End Select
|
||||
Next c
|
||||
|
||||
If dateCol = 0 Or restCol = 0 Then
|
||||
MsgBox "[日历]工作表表头字段不符，请检查！", vbExclamation
|
||||
Set LoadHolidays = dict
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Dim r As Long
|
||||
For r = 2 To lastRow
|
||||
If Not IsEmpty(data(r, dateCol)) Then
|
||||
Dim restVal As Variant
|
||||
restVal = data(r, restCol)
|
||||
' 支持多种"休息"标记：TRUE, 1, "是", "1", "TRUE"
|
||||
Dim isRest As Boolean
|
||||
isRest = (restVal = True) Or (restVal = 1) Or _
|
||||
(UCase(Trim(CStr(restVal))) = "是") Or _
|
||||
(Trim(CStr(restVal)) = "1") Or _
|
||||
(UCase(Trim(CStr(restVal))) = "TRUE")
|
||||
If isRest Then
|
||||
Dim dateKey As Long
|
||||
dateKey = CLng(CDate(data(r, dateCol)))
|
||||
If Not dict.Exists(dateKey) Then
|
||||
dict.Add dateKey, True
|
||||
End If
|
||||
End If
|
||||
End If
|
||||
Next r
|
||||
|
||||
Set LoadHolidays = dict
|
||||
End Function
|
||||
|
||||
'-----------------------------------------------------------------------------
|
||||
' 计算两个日期之间的工作日数（不含节假日）
|
||||
' 说明：从startDate的次日到endDate，逐日判断是否为节假日
|
||||
' 工作日 = 日历天 - 节假日天数
|
||||
'-----------------------------------------------------------------------------
|
||||
Private Function CalcWorkdays(startDate As Date, endDate As Date, holidays As Object) As Long
|
||||
Dim totalDays As Long
|
||||
Dim holidayCount As Long
|
||||
Dim d As Date
|
||||
|
||||
totalDays = DateDiff("d", startDate, endDate)
|
||||
|
||||
If totalDays <= 0 Then
|
||||
CalcWorkdays = 0
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
' 遍历区间内每一天（不含startDate，含endDate）
|
||||
holidayCount = 0
|
||||
For d = startDate + 1 To endDate
|
||||
Dim dk As Long
|
||||
dk = CLng(d)
|
||||
If holidays.Exists(dk) Then
|
||||
holidayCount = holidayCount + 1
|
||||
End If
|
||||
Next d
|
||||
|
||||
CalcWorkdays = totalDays - holidayCount
|
||||
End Function
|
||||
|
||||
'-----------------------------------------------------------------------------
|
||||
' 从[工厂货期]工作表加载货期查询表到二维数组
|
||||
' 输出：
|
||||
' tableData - 完整数据数组（不含表头行），行=产品分类，列=数量范围对应天数
|
||||
' categories() - 产品分类名称数组（与tableData行对应）
|
||||
' rangeHeaders() - 数量范围表头字符串数组，如 "1-20","21-100","101-500"
|
||||
'-----------------------------------------------------------------------------
|
||||
Private Sub LoadFactoryLeadTable(ByRef tableData As Variant, _
|
||||
ByRef categories() As String, _
|
||||
ByRef rangeHeaders() As String)
|
||||
Dim ws As Worksheet
|
||||
' ★ 修复：Worksheet 对象赋值必须使用 Set
|
||||
Set ws = ThisWorkbook.Worksheets("工厂货期")
|
||||
|
||||
Dim lastRow As Long
|
||||
Dim lastCol As Long
|
||||
lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
|
||||
lastCol = ws.Cells(1, ws.Columns.count).End(xlToLeft).Column
|
||||
|
||||
If lastRow < 2 Or lastCol < 2 Then Exit Sub
|
||||
|
||||
' 读取全部数据含表头
|
||||
Dim raw As Variant
|
||||
raw = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol)).Value
|
||||
|
||||
' 解析表头：第1列为产品分类，后续列为数量范围
|
||||
Dim colCount As Long
|
||||
colCount = lastCol - 1 ' 排除产品分类列
|
||||
ReDim rangeHeaders(1 To colCount)
|
||||
Dim c As Long
|
||||
For c = 1 To colCount
|
||||
rangeHeaders(c) = Trim(CStr(raw(1, c + 1)))
|
||||
Next c
|
||||
|
||||
' 解析数据行
|
||||
Dim rowCount As Long
|
||||
rowCount = lastRow - 1
|
||||
ReDim categories(1 To rowCount)
|
||||
ReDim tableData(1 To rowCount, 1 To colCount)
|
||||
|
||||
Dim r As Long
|
||||
For r = 1 To rowCount
|
||||
categories(r) = Trim(CStr(raw(r + 1, 1)))
|
||||
For c = 1 To colCount
|
||||
tableData(r, c) = raw(r + 1, c + 1)
|
||||
Next c
|
||||
Next r
|
||||
End Sub
|
||||
|
||||
'-----------------------------------------------------------------------------
|
||||
' 根据产品分类和数量查询工厂货期（工作日）
|
||||
' 参数：
|
||||
' category - 产品分类名称
|
||||
' qty - 数量
|
||||
' tableData - 货期数值二维数组
|
||||
' categories() - 产品分类名称数组
|
||||
' rangeHeaders() - 数量范围表头数组，如"1-20"
|
||||
' 返回：对应工厂货期天数，找不到返回0
|
||||
'-----------------------------------------------------------------------------
|
||||
Private Function LookupFactoryLead(category As String, qty As Long, _
|
||||
tableData As Variant, _
|
||||
categories() As String, _
|
||||
rangeHeaders() As String) As Long
|
||||
' 找到对应的行（产品分类）
|
||||
Dim targetRow As Long
|
||||
targetRow = 0
|
||||
Dim r As Long
|
||||
For r = 1 To UBound(categories)
|
||||
If categories(r) = category Then
|
||||
targetRow = r
|
||||
Exit For
|
||||
End If
|
||||
Next r
|
||||
|
||||
If targetRow = 0 Then
|
||||
LookupFactoryLead = 0
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
' 找到对应的列（数量范围）
|
||||
Dim targetCol As Long
|
||||
targetCol = 0
|
||||
Dim c As Long
|
||||
For c = 1 To UBound(rangeHeaders)
|
||||
Dim lo As Long, hi As Long
|
||||
If ParseRange(rangeHeaders(c), lo, hi) Then
|
||||
If qty >= lo And qty <= hi Then
|
||||
targetCol = c
|
||||
Exit For
|
||||
End If
|
||||
End If
|
||||
Next c
|
||||
|
||||
If targetCol = 0 Then
|
||||
' 数量超出所有范围，取最后一列
|
||||
targetCol = UBound(rangeHeaders)
|
||||
End If
|
||||
|
||||
LookupFactoryLead = CLng(tableData(targetRow, targetCol))
|
||||
End Function
|
||||
|
||||
'-----------------------------------------------------------------------------
|
||||
' 解析形如 "1-20", "21-100", "101-500" 的范围字符串
|
||||
' 输出：lo（下限），hi（上限）
|
||||
' 返回：True=解析成功，False=失败
|
||||
'-----------------------------------------------------------------------------
|
||||
Private Function ParseRange(rangeStr As String, ByRef lo As Long, ByRef hi As Long) As Boolean
|
||||
Dim parts() As String
|
||||
parts = Split(Trim(rangeStr), "-")
|
||||
If UBound(parts) = 1 Then
|
||||
On Error Resume Next
|
||||
lo = CLng(Trim(parts(0)))
|
||||
hi = CLng(Trim(parts(1)))
|
||||
On Error GoTo 0
|
||||
ParseRange = (lo > 0 And hi >= lo)
|
||||
Else
|
||||
ParseRange = False
|
||||
End If
|
||||
End Function
|
||||
Reference in New Issue
Block a user