c0f8d8163d
- 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>
599 lines
20 KiB
QBasic
599 lines
20 KiB
QBasic
'=============================================================================
|
||
' 模块：货期检查主模块
|
||
' 功能：从[生产订单明细查询]提取数据到[货期检查]，并完成货期分析计算
|
||
'=============================================================================
|
||
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 |