676 lines
24 KiB
QBasic
676 lines
24 KiB
QBasic
' ============================================================================
|
||
' PMC 物控优化方案 - 缺料交期总表 + 数据链路打通 + 字段补全
|
||
' 来源：全機型_日報表.xlsm 优化
|
||
' 创建日期：2026-04-07
|
||
' 适用场景：PMC 物控查缺料、看交期
|
||
' ============================================================================
|
||
|
||
Option Explicit
|
||
|
||
' ============================================================================
|
||
' 方案 C：新建缺料交期总表
|
||
' ============================================================================
|
||
|
||
Sub CreateShortageDeliveryReport()
|
||
' 新建「缺料交期总表」，汇总所有关键信息
|
||
' 自动从 缺料 / qs / TMH / 0000 / KCB 表提取数据
|
||
|
||
Dim wsSource As Worksheet
|
||
Dim wsDest As Worksheet
|
||
Dim wsQS As Worksheet
|
||
Dim wsTMH As Worksheet
|
||
Dim ws0000 As Worksheet
|
||
Dim wsKCB As Worksheet
|
||
Dim dictQS As Object ' qs 数据字典 (料号 → 确认交期/数量)
|
||
Dim dictTMH As Object ' TMH 数据字典 (料号 → 待提数量)
|
||
Dim dictATP As Object ' 0000 数据字典 (料号 → L/T内缺料/接单欠料)
|
||
Dim dictStock As Object ' KCB 数据字典 (料号 → 库存)
|
||
|
||
Dim lastRow As Long, lastRowQS As Long, lastRowTMH As Long
|
||
Dim lastRow0000 As Long, lastRowKCB As Long
|
||
Dim i As Long, destRow As Long
|
||
Dim cpn As String
|
||
Dim shortageQty As Double
|
||
Dim priority As String
|
||
Dim confirmedDate As String
|
||
Dim confirmedQty As Double
|
||
Dim tmhQty As Double
|
||
Dim ltShortage As Double
|
||
Dim poQty As Double
|
||
Dim stockQty As Double
|
||
Dim modelName As String
|
||
Dim vendor As String
|
||
Dim key As Variant
|
||
|
||
' ---- 性能优化 ----
|
||
OptimizeVBA True
|
||
On Error GoTo ErrorHandler
|
||
|
||
' ---- 检查必要工作表 ----
|
||
If Not WorksheetExists("缺料") Then
|
||
MsgBox "「缺料」工作表不存在！", vbExclamation
|
||
GoTo CleanUp
|
||
End If
|
||
Set wsSource = ThisWorkbook.Worksheets("缺料")
|
||
|
||
' ---- 建立字典：从 qs 获取确认交期 ----
|
||
Set dictQS = CreateObject("Scripting.Dictionary")
|
||
If WorksheetExists("qs") Then
|
||
Set wsQS = ThisWorkbook.Worksheets("qs")
|
||
lastRowQS = wsQS.Cells(wsQS.Rows.Count, "E").End(xlUp).Row
|
||
|
||
For i = 2 To lastRowQS
|
||
cpn = Trim(CStr(wsQS.Cells(i, 5).Value)) ' E列 = 茂瑞料号
|
||
If cpn <> "" Then
|
||
' J列 = 厂商回复交期(ETD)
|
||
' K列 = 厂商回复数量
|
||
confirmedDate = Trim(CStr(wsQS.Cells(i, 10).Value))
|
||
confirmedQty = Val(CStr(wsQS.Cells(i, 11).Value))
|
||
|
||
If Not dictQS.exists(cpn) Then
|
||
dictQS.Add cpn, CreateObject("Scripting.Dictionary")
|
||
End If
|
||
dictQS(cpn).Add "ETD", confirmedDate
|
||
dictQS(cpn).Add "Qty", confirmedQty
|
||
End If
|
||
Next i
|
||
End If
|
||
|
||
' ---- 建立字典：从 TMH 获取待提数量 ----
|
||
Set dictTMH = CreateObject("Scripting.Dictionary")
|
||
If WorksheetExists("TMH") Then
|
||
Set wsTMH = ThisWorkbook.Worksheets("TMH")
|
||
lastRowTMH = wsTMH.Cells(wsTMH.Rows.Count, "E").End(xlUp).Row
|
||
|
||
For i = 2 To lastRowTMH
|
||
cpn = Trim(CStr(wsTMH.Cells(i, 5).Value)) ' E列 = 料号
|
||
If cpn <> "" Then
|
||
tmhQty = Val(CStr(wsTMH.Cells(i, 6).Value)) ' F列 = 数量
|
||
If dictTMH.exists(cpn) Then
|
||
dictTMH(cpn) = dictTMH(cpn) + tmhQty
|
||
Else
|
||
dictTMH.Add cpn, tmhQty
|
||
End If
|
||
End If
|
||
Next i
|
||
End If
|
||
|
||
' ---- 建立字典：从 0000 获取 ATP 分析 ----
|
||
Set dictATP = CreateObject("Scripting.Dictionary")
|
||
If WorksheetExists("0000") Then
|
||
Set ws0000 = ThisWorkbook.Worksheets("0000")
|
||
lastRow0000 = ws0000.Cells(ws0000.Rows.Count, "A").End(xlUp).Row
|
||
|
||
For i = 3 To lastRow0000 ' 数据从第3行开始
|
||
cpn = Trim(CStr(ws0000.Cells(i, 1).Value)) ' A列 = P/N
|
||
If cpn <> "" Then
|
||
' Q列 = L/T内缺料, R列 = 接单欠料, N列 = PO
|
||
ltShortage = Val(CStr(ws0000.Cells(i, 17).Value))
|
||
poQty = Val(CStr(ws0000.Cells(i, 14).Value))
|
||
|
||
dictATP.Add cpn, CreateObject("Scripting.Dictionary")
|
||
dictATP(cpn).Add "LT", ltShortage
|
||
dictATP(cpn).Add "PO", poQty
|
||
End If
|
||
Next i
|
||
End If
|
||
|
||
' ---- 建立字典：从 KCB 获取库存 ----
|
||
Set dictStock = CreateObject("Scripting.Dictionary")
|
||
If WorksheetExists("KCB") Then
|
||
Set wsKCB = ThisWorkbook.Worksheets("KCB")
|
||
lastRowKCB = wsKCB.Cells(wsKCB.Rows.Count, "B").End(xlUp).Row
|
||
|
||
For i = 3 To lastRowKCB ' 数据从第3行开始
|
||
cpn = Trim(CStr(wsKCB.Cells(i, 2).Value)) ' B列 = Material
|
||
If cpn <> "" Then
|
||
stockQty = Val(CStr(wsKCB.Cells(i, 3).Value)) ' C列 = UnrestrictedUseQty
|
||
dictStock.Add cpn, stockQty
|
||
End If
|
||
Next i
|
||
End If
|
||
|
||
' ---- 删除旧的工作表 ----
|
||
Application.DisplayAlerts = False
|
||
On Error Resume Next
|
||
ThisWorkbook.Worksheets("缺料交期总表").Delete
|
||
Application.DisplayAlerts = True
|
||
On Error GoTo ErrorHandler
|
||
|
||
' ---- 新建目标工作表 ----
|
||
Set wsDest = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
|
||
wsDest.Name = "缺料交期总表"
|
||
|
||
' ---- 写入表头 ----
|
||
Dim headers As Variant
|
||
headers = Array("序号", "料号", "机种", "IC用途", "IC厂商", _
|
||
"结余/欠料", "PO", "TMH待提", "库存", _
|
||
"L/T内缺料", "接单欠料", _
|
||
"确认交期", "预计到货数量", _
|
||
"优先级", "跟催建议", "备注")
|
||
|
||
Dim col As Long
|
||
For col = 0 To UBound(headers)
|
||
wsDest.Cells(1, col + 1).Value = headers(col)
|
||
wsDest.Cells(1, col + 1).Font.Bold = True
|
||
wsDest.Cells(1, col + 1).Interior.Color = RGB(0, 112, 192)
|
||
wsDest.Cells(1, col + 1).Font.Color = RGB(255, 255, 255)
|
||
Next col
|
||
|
||
' ---- 读取缺料表数据 ----
|
||
lastRow = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row
|
||
destRow = 2
|
||
|
||
For i = 4 To lastRow ' 数据从第4行开始（第3行是表头）
|
||
cpn = Trim(CStr(wsSource.Cells(i, 2).Value)) ' B列 = CPN
|
||
If cpn = "" Or cpn = "0" Then GoTo NextRow
|
||
|
||
' 基础字段
|
||
wsDest.Cells(destRow, 1).Value = wsSource.Cells(i, 1).Value ' 序号
|
||
wsDest.Cells(destRow, 2).Value = cpn ' 料号
|
||
wsDest.Cells(destRow, 3).Value = wsSource.Cells(i, 3).Value ' 机种
|
||
wsDest.Cells(destRow, 4).Value = wsSource.Cells(i, 4).Value ' IC用途
|
||
wsDest.Cells(destRow, 5).Value = wsSource.Cells(i, 5).Value ' IC厂商
|
||
wsDest.Cells(destRow, 6).Value = wsSource.Cells(i, 7).Value ' 结余/欠料
|
||
wsDest.Cells(destRow, 7).Value = wsSource.Cells(i, 10).Value ' PO
|
||
|
||
' TMH 待提
|
||
If dictTMH.exists(cpn) Then
|
||
wsDest.Cells(destRow, 8).Value = dictTMH(cpn)
|
||
Else
|
||
wsDest.Cells(destRow, 8).Value = 0
|
||
End If
|
||
|
||
' 库存
|
||
If dictStock.exists(cpn) Then
|
||
wsDest.Cells(destRow, 9).Value = dictStock(cpn)
|
||
Else
|
||
wsDest.Cells(destRow, 9).Value = 0
|
||
End If
|
||
|
||
' ATP 数据
|
||
If dictATP.exists(cpn) Then
|
||
wsDest.Cells(destRow, 10).Value = dictATP(cpn)("LT") ' L/T内缺料
|
||
wsDest.Cells(destRow, 11).Value = dictATP(cpn)("PO") ' 接单欠料
|
||
Else
|
||
wsDest.Cells(destRow, 10).Value = ""
|
||
wsDest.Cells(destRow, 11).Value = ""
|
||
End If
|
||
|
||
' qs 确认交期
|
||
If dictQS.exists(cpn) Then
|
||
wsDest.Cells(destRow, 12).Value = dictQS(cpn)("ETD") ' 确认交期
|
||
wsDest.Cells(destRow, 13).Value = dictQS(cpn)("Qty") ' 预计到货数量
|
||
Else
|
||
wsDest.Cells(destRow, 12).Value = "待确认"
|
||
wsDest.Cells(destRow, 13).Value = 0
|
||
End If
|
||
|
||
' ---- 计算优先级 ----
|
||
shortageQty = Val(CStr(wsSource.Cells(i, 7).Value)) ' G列 = 结余/欠料
|
||
poQty = Val(CStr(wsSource.Cells(i, 10).Value)) ' J列 = PO
|
||
|
||
If shortageQty < 0 And poQty = 0 Then
|
||
priority = "高"
|
||
wsDest.Cells(destRow, 15).Value = "高"
|
||
wsDest.Cells(destRow, 15).Interior.Color = RGB(255, 0, 0)
|
||
wsDest.Cells(destRow, 15).Font.Color = RGB(255, 255, 255)
|
||
wsDest.Cells(destRow, 16).Value = "紧急跟催：结余为负且无PO，立即联系采购"
|
||
ElseIf shortageQty < 0 And poQty > 0 Then
|
||
priority = "中"
|
||
wsDest.Cells(destRow, 15).Value = "中"
|
||
wsDest.Cells(destRow, 15).Interior.Color = RGB(255, 192, 0)
|
||
wsDest.Cells(destRow, 16).Value = "跟催交期：确认PO交期，追踪厂商回复"
|
||
ElseIf shortageQty >= 0 And dictStock.exists(cpn) Then
|
||
If dictStock(cpn) < shortageQty Then
|
||
priority = "中"
|
||
wsDest.Cells(destRow, 15).Value = "中"
|
||
wsDest.Cells(destRow, 15).Interior.Color = RGB(255, 192, 0)
|
||
wsDest.Cells(destRow, 16).Value = "库存不足：核对备料需求"
|
||
Else
|
||
priority = "低"
|
||
wsDest.Cells(destRow, 15).Value = "低"
|
||
wsDest.Cells(destRow, 15).Interior.Color = RGB(0, 176, 80)
|
||
wsDest.Cells(destRow, 16).Value = "正常：库存可覆盖"
|
||
End If
|
||
Else
|
||
priority = "低"
|
||
wsDest.Cells(destRow, 15).Value = "低"
|
||
wsDest.Cells(destRow, 15).Interior.Color = RGB(0, 176, 80)
|
||
wsDest.Cells(destRow, 16).Value = "正常"
|
||
End If
|
||
|
||
' 备注
|
||
If dictQS.exists(cpn) Then
|
||
wsDest.Cells(destRow, 17).Value = "qs有订单"
|
||
Else
|
||
wsDest.Cells(destRow, 17).Value = "qs无订单"
|
||
End If
|
||
|
||
destRow = destRow + 1
|
||
|
||
NextRow:
|
||
Next i
|
||
|
||
' ---- 格式调整 ----
|
||
wsDest.Columns.AutoFit
|
||
wsDest.Range("A1").AutoFilter
|
||
|
||
' 冻结首行
|
||
wsDest.Activate
|
||
ActiveWindow.FreezePanes = False
|
||
wsDest.Rows(1).Select
|
||
ActiveWindow.FreezePanes = True
|
||
|
||
' ---- 完成 ----
|
||
Application.StatusBar = False
|
||
MsgBox "缺料交期总表已生成！" & vbCrLf & _
|
||
"共 " & (destRow - 2) & " 条记录" & vbCrLf & _
|
||
"高优先级：红色标注" & vbCrLf & _
|
||
"中优先级：橙色标注" & vbCrLf & _
|
||
"低优先级：绿色标注", vbInformation, "缺料交期总表"
|
||
|
||
GoTo CleanUp
|
||
|
||
ErrorHandler:
|
||
MsgBox "错误 " & Err.Number & "：" & Err.Description, vbCritical
|
||
|
||
CleanUp:
|
||
OptimizeVBA False
|
||
Set wsSource = Nothing
|
||
Set wsDest = Nothing
|
||
Set wsQS = Nothing
|
||
Set wsTMH = Nothing
|
||
Set ws0000 = Nothing
|
||
Set wsKCB = Nothing
|
||
Set dictQS = Nothing
|
||
Set dictTMH = Nothing
|
||
Set dictATP = Nothing
|
||
Set dictStock = Nothing
|
||
End Sub
|
||
|
||
|
||
' ============================================================================
|
||
' 方案 A：计算缺料表优先级（更新 缺料 表 R 列）
|
||
' ============================================================================
|
||
|
||
Sub UpdateShortagePriority()
|
||
' 更新「缺料」工作表的 R 列（优先级）和 P 列（确认交期）
|
||
' 来源：qs 表的确认交期
|
||
|
||
Dim wsShortage As Worksheet
|
||
Dim wsQS As Worksheet
|
||
Dim ws0000 As Worksheet
|
||
Dim lastRow As Long, lastRowQS As Long
|
||
Dim i As Long, j As Long
|
||
Dim cpn As String
|
||
Dim confirmedDate As String
|
||
Dim confirmedQty As Double
|
||
Dim shortageQty As Double
|
||
Dim poQty As Double
|
||
Dim dictQS As Object
|
||
|
||
OptimizeVBA True
|
||
On Error GoTo ErrorHandler
|
||
|
||
' ---- 检查工作表 ----
|
||
If Not WorksheetExists("缺料") Then
|
||
MsgBox "「缺料」工作表不存在！", vbExclamation
|
||
GoTo CleanUp
|
||
End If
|
||
Set wsShortage = ThisWorkbook.Worksheets("缺料")
|
||
|
||
' ---- 建立 qs 数据字典 ----
|
||
Set dictQS = CreateObject("Scripting.Dictionary")
|
||
If WorksheetExists("qs") Then
|
||
Set wsQS = ThisWorkbook.Worksheets("qs")
|
||
lastRowQS = wsQS.Cells(wsQS.Rows.Count, "E").End(xlUp).Row
|
||
|
||
For i = 2 To lastRowQS
|
||
cpn = Trim(CStr(wsQS.Cells(i, 5).Value)) ' E列 = 茂瑞料号
|
||
If cpn <> "" Then
|
||
confirmedDate = Trim(CStr(wsQS.Cells(i, 10).Value)) ' J列 = ETD
|
||
confirmedQty = Val(CStr(wsQS.Cells(i, 11).Value)) ' K列 = 数量
|
||
|
||
If Not dictQS.exists(cpn) Then
|
||
dictQS.Add cpn, CreateObject("Scripting.Dictionary")
|
||
End If
|
||
dictQS(cpn).Add "ETD", confirmedDate
|
||
dictQS(cpn).Add "Qty", confirmedQty
|
||
End If
|
||
Next i
|
||
End If
|
||
|
||
' ---- 获取 0000 的 PO 数据 ----
|
||
Dim dictPO As Object
|
||
Set dictPO = CreateObject("Scripting.Dictionary")
|
||
If WorksheetExists("0000") Then
|
||
Dim ws0000 As Worksheet
|
||
Set ws0000 = ThisWorkbook.Worksheets("0000")
|
||
Dim lastRow0000 As Long
|
||
lastRow0000 = ws0000.Cells(ws0000.Rows.Count, "A").End(xlUp).Row
|
||
|
||
For i = 3 To lastRow0000
|
||
cpn = Trim(CStr(ws0000.Cells(i, 1).Value))
|
||
poQty = Val(CStr(ws0000.Cells(i, 14).Value)) ' N列 = PO
|
||
If cpn <> "" Then dictPO.Add cpn, poQty
|
||
Next i
|
||
End If
|
||
|
||
' ---- 更新缺料表 ----
|
||
lastRow = wsShortage.Cells(wsShortage.Rows.Count, "B").End(xlUp).Row
|
||
|
||
' 确保 P、Q、R 列有表头
|
||
If wsShortage.Cells(3, 16).Value = "" Then wsShortage.Cells(3, 16).Value = "交期" ' P列
|
||
If wsShortage.Cells(3, 17).Value = "" Then wsShortage.Cells(3, 17).Value = "预计到货" ' Q列
|
||
If wsShortage.Cells(3, 18).Value = "" Then wsShortage.Cells(3, 18).Value = "优先级" ' R列
|
||
|
||
For i = 4 To lastRow
|
||
cpn = Trim(CStr(wsShortage.Cells(i, 2).Value)) ' B列 = CPN
|
||
If cpn = "" Or cpn = "0" Then GoTo NextShortage
|
||
|
||
' ---- 回填确认交期 (P列) 和预计到货 (Q列) ----
|
||
If dictQS.exists(cpn) Then
|
||
wsShortage.Cells(i, 16).Value = dictQS(cpn)("ETD") ' P列 = 交期
|
||
wsShortage.Cells(i, 17).Value = dictQS(cpn)("Qty") ' Q列 = 预计到货
|
||
Else
|
||
wsShortage.Cells(i, 16).Value = "待确认"
|
||
wsShortage.Cells(i, 17).Value = 0
|
||
End If
|
||
|
||
' ---- 计算优先级 (R列) ----
|
||
shortageQty = Val(CStr(wsShortage.Cells(i, 7).Value)) ' G列 = 结余/欠料
|
||
If dictPO.exists(cpn) Then
|
||
poQty = dictPO(cpn)
|
||
Else
|
||
poQty = Val(CStr(wsShortage.Cells(i, 10).Value)) ' J列 = PO
|
||
End If
|
||
|
||
If shortageQty < 0 And poQty = 0 Then
|
||
wsShortage.Cells(i, 18).Value = "高" ' R列 = 优先级
|
||
wsShortage.Cells(i, 18).Interior.Color = RGB(255, 0, 0)
|
||
wsShortage.Cells(i, 18).Font.Color = RGB(255, 255, 255)
|
||
ElseIf shortageQty < 0 And poQty > 0 Then
|
||
wsShortage.Cells(i, 18).Value = "中"
|
||
wsShortage.Cells(i, 18).Interior.Color = RGB(255, 192, 0)
|
||
ElseIf shortageQty >= 0 Then
|
||
wsShortage.Cells(i, 18).Value = "低"
|
||
wsShortage.Cells(i, 18).Interior.Color = RGB(0, 176, 80)
|
||
wsShortage.Cells(i, 18).Font.Color = RGB(255, 255, 255)
|
||
End If
|
||
|
||
NextShortage:
|
||
Next i
|
||
|
||
MsgBox "缺料表优先级已更新！" & vbCrLf & _
|
||
"P列：确认交期（来自qs）" & vbCrLf & _
|
||
"Q列：预计到货数量" & vbCrLf & _
|
||
"R列：优先级（高=红色，中=橙色，低=绿色）", vbInformation
|
||
GoTo CleanUp
|
||
|
||
ErrorHandler:
|
||
MsgBox "错误 " & Err.Number & "：" & Err.Description, vbCritical
|
||
|
||
CleanUp:
|
||
OptimizeVBA False
|
||
Set wsShortage = Nothing
|
||
Set wsQS = Nothing
|
||
Set ws0000 = Nothing
|
||
Set dictQS = Nothing
|
||
Set dictPO = Nothing
|
||
End Sub
|
||
|
||
|
||
' ============================================================================
|
||
' 方案 B：从 qs 回填确认交期到缺料表（P 列）
|
||
' ============================================================================
|
||
|
||
Sub FillConfirmedDelivery()
|
||
' 将 qs 表中有确认交期的料号回填到「缺料」表的 P 列
|
||
' 前提：qs 表 J 列（ETD）已有数据
|
||
|
||
Dim wsQS As Worksheet
|
||
Dim wsShortage As Worksheet
|
||
Dim lastRowQS As Long, lastRowS As Long
|
||
Dim dict As Object
|
||
Dim i As Long, j As Long
|
||
Dim cpn As String
|
||
Dim confirmedDate As String
|
||
Dim confirmedQty As Double
|
||
Dim foundCount As Long
|
||
Dim notFoundCount As Long
|
||
|
||
OptimizeVBA True
|
||
On Error GoTo ErrorHandler
|
||
|
||
If Not WorksheetExists("qs") Then
|
||
MsgBox "「qs」工作表不存在！", vbExclamation
|
||
GoTo CleanUp
|
||
End If
|
||
If Not WorksheetExists("缺料") Then
|
||
MsgBox "「缺料」工作表不存在！", vbExclamation
|
||
GoTo CleanUp
|
||
End If
|
||
|
||
Set wsQS = ThisWorkbook.Worksheets("qs")
|
||
Set wsShortage = ThisWorkbook.Worksheets("缺料")
|
||
|
||
' ---- 建立 qs 数据字典 ----
|
||
Set dict = CreateObject("Scripting.Dictionary")
|
||
lastRowQS = wsQS.Cells(wsQS.Rows.Count, "E").End(xlUp).Row
|
||
|
||
For i = 2 To lastRowQS
|
||
cpn = Trim(CStr(wsQS.Cells(i, 5).Value)) ' E列 = 茂瑞料号
|
||
If cpn <> "" Then
|
||
confirmedDate = Trim(CStr(wsQS.Cells(i, 10).Value)) ' J列 = ETD
|
||
confirmedQty = Val(CStr(wsQS.Cells(i, 11).Value)) ' K列 = 数量
|
||
|
||
If confirmedDate <> "" Then
|
||
' 同一料号多条 PO，累加数量
|
||
If dict.exists(cpn) Then
|
||
dict(cpn)("Qty") = dict(cpn)("Qty") + confirmedQty
|
||
' 交期取最早
|
||
If confirmedDate < dict(cpn)("ETD") Then
|
||
dict(cpn)("ETD") = confirmedDate
|
||
End If
|
||
Else
|
||
dict.Add cpn, CreateObject("Scripting.Dictionary")
|
||
dict(cpn).Add "ETD", confirmedDate
|
||
dict(cpn).Add "Qty", confirmedQty
|
||
End If
|
||
End If
|
||
End If
|
||
Next i
|
||
|
||
' ---- 回填到缺料表 P、Q 列 ----
|
||
lastRowS = wsShortage.Cells(wsShortage.Rows.Count, "B").End(xlUp).Row
|
||
foundCount = 0
|
||
notFoundCount = 0
|
||
|
||
For i = 4 To lastRowS
|
||
cpn = Trim(CStr(wsShortage.Cells(i, 2).Value)) ' B列 = CPN
|
||
If cpn = "" Or cpn = "0" Then GoTo NextItem
|
||
|
||
If dict.exists(cpn) Then
|
||
wsShortage.Cells(i, 16).Value = dict(cpn)("ETD") ' P列 = 交期
|
||
wsShortage.Cells(i, 17).Value = dict(cpn)("Qty") ' Q列 = 数量
|
||
foundCount = foundCount + 1
|
||
Else
|
||
notFoundCount = notFoundCount + 1
|
||
End If
|
||
|
||
NextItem:
|
||
Next i
|
||
|
||
MsgBox "交期回填完成！" & vbCrLf & _
|
||
"已匹配并回填：" & foundCount & " 条" & vbCrLf & _
|
||
"qs 中无此料号：" & notFoundCount & " 条", vbInformation
|
||
|
||
GoTo CleanUp
|
||
|
||
ErrorHandler:
|
||
MsgBox "错误 " & Err.Number & "：" & Err.Description, vbCritical
|
||
|
||
CleanUp:
|
||
OptimizeVBA False
|
||
Set wsQS = Nothing
|
||
Set wsShortage = Nothing
|
||
Set dict = Nothing
|
||
End Sub
|
||
|
||
|
||
' ============================================================================
|
||
' 方案 B：TMH 入库后同步状态到 qs
|
||
' ============================================================================
|
||
|
||
Sub SyncTMHToQS()
|
||
' 当 TMH 表有实际入库后，更新 qs 表中对应料号的已交货数量
|
||
' 逻辑：
|
||
' 1. 读取 TMH 的料号和数量
|
||
' 2. 在 qs 中找到对应料号的订单
|
||
' 3. 减少 qs 中该料号的剩余未交数量
|
||
|
||
Dim wsTMH As Worksheet
|
||
Dim wsQS As Worksheet
|
||
Dim lastRowTMH As Long, lastRowQS As Long
|
||
Dim dictTMH As Object
|
||
Dim i As Long, j As Long
|
||
Dim cpn As String
|
||
Dim inQty As Double
|
||
Dim matchCount As Long
|
||
Dim unmatchCount As Long
|
||
|
||
OptimizeVBA True
|
||
On Error GoTo ErrorHandler
|
||
|
||
If Not WorksheetExists("TMH") Then
|
||
MsgBox "「TMH」工作表不存在！", vbExclamation
|
||
GoTo CleanUp
|
||
End If
|
||
If Not WorksheetExists("qs") Then
|
||
MsgBox "「qs」工作表不存在！", vbExclamation
|
||
GoTo CleanUp
|
||
End If
|
||
|
||
Set wsTMH = ThisWorkbook.Worksheets("TMH")
|
||
Set wsQS = ThisWorkbook.Worksheets("qs")
|
||
|
||
' ---- 建立 TMH 汇总字典 ----
|
||
Set dictTMH = CreateObject("Scripting.Dictionary")
|
||
lastRowTMH = wsTMH.Cells(wsTMH.Rows.Count, "E").End(xlUp).Row
|
||
|
||
For i = 2 To lastRowTMH
|
||
cpn = Trim(CStr(wsTMH.Cells(i, 5).Value)) ' E列 = 料号
|
||
inQty = Val(CStr(wsTMH.Cells(i, 6).Value)) ' F列 = 数量
|
||
|
||
If cpn <> "" Then
|
||
If dictTMH.exists(cpn) Then
|
||
dictTMH(cpn) = dictTMH(cpn) + inQty
|
||
Else
|
||
dictTMH.Add cpn, inQty
|
||
End If
|
||
End If
|
||
Next i
|
||
|
||
' ---- 在 qs 中更新已交货 ----
|
||
lastRowQS = wsQS.Cells(wsQS.Rows.Count, "E").End(xlUp).Row
|
||
matchCount = 0
|
||
|
||
For i = 2 To lastRowQS
|
||
cpn = Trim(CStr(wsQS.Cells(i, 5).Value)) ' E列 = 茂瑞料号
|
||
If cpn <> "" And dictTMH.exists(cpn) Then
|
||
' K列 = 厂商回复数量（已交货），L列 = 交期确认
|
||
wsQS.Cells(i, 11).Value = dictTMH(cpn) ' 标记已交货数量
|
||
wsQS.Cells(i, 12).Value = "Y" ' 标记已确认
|
||
matchCount = matchCount + 1
|
||
End If
|
||
Next i
|
||
|
||
MsgBox "TMH 已同步到 qs！" & vbCrLf & _
|
||
"共更新 " & matchCount & " 条记录", vbInformation
|
||
|
||
GoTo CleanUp
|
||
|
||
ErrorHandler:
|
||
MsgBox "错误 " & Err.Number & "：" & Err.Description, vbCritical
|
||
|
||
CleanUp:
|
||
OptimizeVBA False
|
||
Set wsTMH = Nothing
|
||
Set wsQS = Nothing
|
||
Set dictTMH = Nothing
|
||
End Sub
|
||
|
||
|
||
' ============================================================================
|
||
' 一键刷新：运行所有优化宏（推荐绑定 Ctrl+Shift+R）
|
||
' ============================================================================
|
||
|
||
Sub RefreshAllData()
|
||
' 按顺序执行所有优化宏
|
||
' 1. 更新缺料优先级 + 回填交期
|
||
' 2. 生成缺料交期总表
|
||
|
||
Dim startTime As Double
|
||
startTime = Timer
|
||
|
||
Application.StatusBar = "正在刷新数据..."
|
||
|
||
' 步骤1：回填 qs 交期到缺料表
|
||
Application.StatusBar = "步骤 1/3：回填确认交期..."
|
||
Call FillConfirmedDelivery
|
||
|
||
' 步骤2：更新优先级
|
||
Application.StatusBar = "步骤 2/3：计算优先级..."
|
||
Call UpdateShortagePriority
|
||
|
||
' 步骤3：生成交期总表
|
||
Application.StatusBar = "步骤 3/3：生成缺料交期总表..."
|
||
Call CreateShortageDeliveryReport
|
||
|
||
Application.StatusBar = False
|
||
|
||
MsgBox "数据刷新完成！" & vbCrLf & _
|
||
"耗时：" & Format(Timer - startTime, "0.00") & " 秒" & vbCrLf & _
|
||
"请查看「缺料交期总表」了解缺料与交期全貌", vbInformation, "刷新完成"
|
||
End Sub
|
||
|
||
|
||
' ============================================================================
|
||
' 辅助函数
|
||
' ============================================================================
|
||
|
||
Function WorksheetExists(sheetName As String) As Boolean
|
||
On Error Resume Next
|
||
WorksheetExists = Not ThisWorkbook.Sheets(sheetName) Is Nothing
|
||
On Error GoTo 0
|
||
End Function
|
||
|
||
Sub OptimizeVBA(Optimize As Boolean)
|
||
With Application
|
||
If Optimize Then
|
||
.ScreenUpdating = False
|
||
.Calculation = xlCalculationManual
|
||
.DisplayAlerts = False
|
||
.EnableEvents = False
|
||
.StatusBar = "处理中..."
|
||
Else
|
||
.ScreenUpdating = True
|
||
.Calculation = xlCalculationAutomatic
|
||
.DisplayAlerts = True
|
||
.EnableEvents = True
|
||
.StatusBar = False
|
||
End If
|
||
End With
|
||
End Sub
|
||
|
||
|
||
' ============================================================================
|
||
' 快捷键设置说明（在 VBA 编辑器中设置）
|
||
' ============================================================================
|
||
' 1. 在 VBA 编辑器中，点击 ThisWorkbook
|
||
' 2. 选择 "工具" -> "宏" -> "RefreshAllData" -> "选项"
|
||
' 3. 设置快捷键为 Ctrl+Shift+R
|
||
' 4. 保存后，每次按 Ctrl+Shift+R 即可一键刷新所有数据
|
||
' ============================================================================
|